(!cold-init-forms
(/show0 "entering !PACKAGE-COLD-INIT"))
\f
+;;;; Thread safety
+;;;;
+;;;; ...this could still use work, but the basic idea is:
+;;;;
+;;;; *PACKAGE-GRAPH-LOCK* is held via WITH-PACKAGE-GRAPH while working on
+;;;; package graph, including package -> package links, and interning and
+;;;; uninterning symbols.
+;;;;
+;;;; Hash-table lock on *PACKAGE-NAMES* is held via WITH-PACKAGE-NAMES while
+;;;; frobbing name -> package associations.
+;;;;
+;;;; There should be no deadlocks due to ordering issues between these two, as
+;;;; the latter is only held over operations guaranteed to terminate in finite
+;;;; time.
+;;;;
+;;;; Errors may be signalled while holding on to the *PACKAGE-GRAPH-LOCK*,
+;;;; which can still lead to pretty damned inconvenient situations -- but
+;;;; since FIND-PACKAGE, FIND-SYMBOL from other threads isn't blocked by this,
+;;;; the situation isn't *quite* hopeless.
+;;;;
+;;;; A better long-term solution seems to be in splitting the granularity of
+;;;; the *PACKAGE-GRAPH-LOCK* down: for interning a per-package lock should be
+;;;; sufficient, though interaction between parallel intern and use-package
+;;;; needs to be considered with some care.
+
+(defvar *package-graph-lock*)
+(!cold-init-forms
+ (setf *package-graph-lock* (sb!thread:make-mutex :name "Package Graph Lock")))
+
+(defun call-with-package-graph (function)
+ (declare (function function))
+ ;; FIXME: Since name conflicts can be signalled while holding the
+ ;; mutex, user code can be run leading to lock ordering problems.
+ ;;
+ ;; This used to be a spinlock, but there it can be held for a long
+ ;; time while the debugger waits for user input.
+ (sb!thread:with-recursive-lock (*package-graph-lock*)
+ (funcall function)))
+
+;;; a map from package names to packages
+(defvar *package-names*)
+(declaim (type hash-table *package-names*))
+(!cold-init-forms
+ (setf *package-names* (make-hash-table :test 'equal :synchronized t)))
+
+(defmacro with-package-names ((names &key) &body body)
+ `(let ((,names *package-names*))
+ (with-locked-hash-table (,names)
+ ,@body)))
+\f
;;;; PACKAGE-HASHTABLE stuff
(def!method print-object ((table package-hashtable) stream)
(declare (type stream stream))
(print-unreadable-object (table stream :type t)
(format stream
- ":SIZE ~S :FREE ~S :DELETED ~S"
- (package-hashtable-size table)
- (package-hashtable-free table)
- (package-hashtable-deleted table))))
+ ":SIZE ~S :FREE ~S :DELETED ~S"
+ (package-hashtable-size table)
+ (package-hashtable-free table)
+ (package-hashtable-deleted table))))
+
+;;; the maximum load factor we allow in a package hashtable
+(defconstant +package-rehash-threshold+ 0.75)
-;;; the maximum density we allow in a package hashtable
-(defconstant package-rehash-threshold 0.75)
+;;; the load factor desired for a package hashtable when writing a
+;;; core image
+(defconstant +package-hashtable-image-load-factor+ 0.5)
;;; Make a package hashtable having a prime number of entries at least
-;;; as great as (/ SIZE PACKAGE-REHASH-THRESHOLD). If RES is supplied,
+;;; 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.
+;;; Actually, the smallest table built here has three entries. This
+;;; is necessary because the double hashing step size is calculated
+;;; using a division by the table size minus two.
(defun make-or-remake-package-hashtable (size
- &optional
+ &optional
res)
(flet ((actual-package-hashtable-size (size)
(loop for n of-type fixnum
- from (logior (truncate size package-rehash-threshold) 1)
+ from (logior (ceiling size +package-rehash-threshold+) 1)
by 2
when (positive-primep n) return n)))
(let* ((n (actual-package-hashtable-size size))
- (size (truncate (* n package-rehash-threshold)))
+ (size (truncate (* n +package-rehash-threshold+)))
(table (make-array n))
(hash (make-array n
:element-type '(unsigned-byte 8)
(package-hashtable-deleted res) 0)
(setf res (%make-package-hashtable table hash size)))
res)))
+
+;;; Destructively resize TABLE to have room for at least SIZE entries
+;;; and rehash its existing entries.
+(defun resize-package-hashtable (table size)
+ (let* ((vec (package-hashtable-table table))
+ (hash (package-hashtable-hash table))
+ (len (length vec)))
+ (make-or-remake-package-hashtable size table)
+ (dotimes (i len)
+ (when (> (aref hash i) 1)
+ (add-symbol table (svref vec i))))))
\f
;;;; package locking operations, built conditionally on :sb-package-locks
#!+sb-package-locks
(progn
-(defun package-locked-p (package)
- #!+sb-doc
+(defun package-locked-p (package)
+ #!+sb-doc
"Returns T when PACKAGE is locked, NIL otherwise. Signals an error
if PACKAGE doesn't designate a valid package."
(package-lock (find-undeleted-package-or-lose package)))
(defun lock-package (package)
- #!+sb-doc
+ #!+sb-doc
"Locks PACKAGE and returns T. Has no effect if PACKAGE was already
locked. Signals an error if PACKAGE is not a valid package designator"
(setf (package-lock (find-undeleted-package-or-lose package)) t))
(defun unlock-package (package)
- #!+sb-doc
+ #!+sb-doc
"Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already
unlocked. Signals an error if PACKAGE is not a valid package designator."
(setf (package-lock (find-undeleted-package-or-lose package)) nil)
t)
(defun package-implemented-by-list (package)
- #!+sb-doc
+ #!+sb-doc
"Returns a list containing the implementation packages of
PACKAGE. Signals an error if PACKAGE is not a valid package designator."
(package-%implementation-packages (find-undeleted-package-or-lose package)))
-(defun package-implements-list (package)
- #!+sb-doc
+(defun package-implements-list (package)
+ #!+sb-doc
"Returns the packages that PACKAGE is an implementation package
of. Signals an error if PACKAGE is not a valid package designator."
(let ((package (find-undeleted-package-or-lose package)))
when (member package (package-%implementation-packages x))
collect x)))
-(defun add-implementation-package (packages-to-add
- &optional (package *package*))
- #!+sb-doc
+(defun add-implementation-package (packages-to-add
+ &optional (package *package*))
+ #!+sb-doc
"Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals
an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid
package designator."
(let ((package (find-undeleted-package-or-lose package))
- (packages-to-add (package-listify packages-to-add)))
+ (packages-to-add (package-listify packages-to-add)))
(setf (package-%implementation-packages package)
(union (package-%implementation-packages package)
(mapcar #'find-undeleted-package-or-lose packages-to-add)))))
-(defun remove-implementation-package (packages-to-remove
- &optional (package *package*))
- #!+sb-doc
+(defun remove-implementation-package (packages-to-remove
+ &optional (package *package*))
+ #!+sb-doc
"Removes PACKAGES-TO-REMOVE from the implementation packages of
PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE
is not a valid package designator."
(let ((package (find-undeleted-package-or-lose package))
- (packages-to-remove (package-listify packages-to-remove)))
+ (packages-to-remove (package-listify packages-to-remove)))
(setf (package-%implementation-packages package)
- (nset-difference
+ (nset-difference
(package-%implementation-packages package)
(mapcar #'find-undeleted-package-or-lose packages-to-remove)))))
(with-unique-names (unlocked-packages)
`(let (,unlocked-packages)
(unwind-protect
- (progn
+ (progn
(dolist (p ',packages)
(when (package-locked-p p)
(push p ,unlocked-packages)
(unlock-package p)))
,@forms)
(dolist (p ,unlocked-packages)
- (when (find-package p)
- (lock-package p)))))))
+ (when (find-package p)
+ (lock-package p)))))))
(defun package-lock-violation (package &key (symbol nil symbol-p)
format-control format-arguments)
;; comparison to *package*, since during cold init this gets
;; called before *package* is bound -- but no package should
;; be locked at that point.
- (and package
+ (and package
(package-lock package)
;; In package or implementation package
(not (or (eq package *package*)
;;;
;;; Must be used inside the dynamic contour established by
;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR
-(defun assert-package-unlocked (package &optional format-control
- &rest format-arguments)
- #!-sb-package-locks
+(defun assert-package-unlocked (package &optional format-control
+ &rest format-arguments)
+ #!-sb-package-locks
(declare (ignore format-control format-arguments))
#!+sb-package-locks
(when (package-lock-violation-p package)
- (package-lock-violation package
- :format-control format-control
- :format-arguments format-arguments))
+ (package-lock-violation package
+ :format-control format-control
+ :format-arguments format-arguments))
package)
;;; Must be used inside the dynamic contour established by
(declare (ignore format))
#!+sb-package-locks
(let* ((symbol (etypecase name
- (symbol name)
- (list (if (eq 'setf (first name))
- (second name)
- ;; Skip (class-predicate foo), etc.
- ;; FIXME: MOP and package-lock
- ;; interaction needs to be thought about.
- (return-from
- assert-symbol-home-package-unlocked
- name)))))
- (package (symbol-package symbol)))
+ (symbol name)
+ (list (if (and (consp (cdr name))
+ (eq 'setf (first name)))
+ (second name)
+ ;; Skip lists of length 1, single conses and
+ ;; (class-predicate foo), etc.
+ ;; FIXME: MOP and package-lock
+ ;; interaction needs to be thought about.
+ (return-from
+ assert-symbol-home-package-unlocked
+ name)))))
+ (package (symbol-package symbol)))
(when (package-lock-violation-p package symbol)
- (package-lock-violation package
- :symbol symbol
- :format-control format
- :format-arguments (list name))))
+ (package-lock-violation package
+ :symbol symbol
+ :format-control format
+ :format-arguments (list name))))
name)
\f
(def!method print-object ((package package) stream)
(let ((name (package-%name package)))
(if name
- (print-unreadable-object (package stream :type t)
- (prin1 name stream))
- (print-unreadable-object (package stream :type t :identity t)
- (write-string "(deleted)" stream)))))
+ (print-unreadable-object (package stream :type t)
+ (prin1 name stream))
+ (print-unreadable-object (package stream :type t :identity t)
+ (write-string "(deleted)" stream)))))
;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and
;;; most other operations, are unspecified for deleted packages. We
;;; just do the easy thing and signal errors in that case.
(macrolet ((def (ext real)
- `(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
+ `(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
(def package-nicknames package-%nicknames)
(def package-use-list package-%use-list)
(def package-used-by-list package-%used-by-list)
(defun %package-hashtable-symbol-count (table)
(let ((size (the fixnum
- (- (package-hashtable-size table)
- (package-hashtable-deleted table)))))
+ (- (package-hashtable-size table)
+ (package-hashtable-deleted table)))))
(the fixnum
(- size (package-hashtable-free table)))))
(defun package-external-symbol-count (package)
(%package-hashtable-symbol-count (package-external-symbols package)))
\f
-(defvar *package* (error "*PACKAGE* should be initialized in cold load!")
+(defvar *package* (error "*PACKAGE* should be initialized in cold load!")
#!+sb-doc "the current package")
;;; FIXME: should be declared of type PACKAGE, with no NIL init form,
;;; after I get around to cleaning up DOCUMENTATION
-;;; a map from package names to packages
-(defvar *package-names*)
-(declaim (type hash-table *package-names*))
-(!cold-init-forms
- (setf *package-names* (make-hash-table :test 'equal)))
-
;;; This magical variable is T during initialization so that
;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such
;;; packages are thrown onto the list *DEFERRED-USE-PACKAGES* so that
(define-condition bootstrap-package-not-found (condition)
((name :initarg :name :reader bootstrap-package-name)))
(defun debootstrap-package (&optional condition)
- (invoke-restart
+ (invoke-restart
(find-restart-or-control-error 'debootstrap-package condition)))
-
+
(defun find-package (package-designator)
(flet ((find-package-from-string (string)
- (declare (type string string))
- (let ((packageoid (gethash string *package-names*)))
- (when (and (null packageoid)
- (not *in-package-init*) ; KLUDGE
- (let ((mismatch (mismatch "SB!" string)))
- (and mismatch (= mismatch 3))))
- (restart-case
- (signal 'bootstrap-package-not-found :name string)
- (debootstrap-package ()
- (return-from find-package
- (if (string= string "SB!XC")
- (find-package "COMMON-LISP")
- (find-package
- (substitute #\- #\! string :count 1)))))))
- packageoid)))
+ (declare (type string string))
+ (let ((packageoid (gethash string *package-names*)))
+ (when (and (null packageoid)
+ (not *in-package-init*) ; KLUDGE
+ (let ((mismatch (mismatch "SB!" string)))
+ (and mismatch (= mismatch 3))))
+ (restart-case
+ (signal 'bootstrap-package-not-found :name string)
+ (debootstrap-package ()
+ (return-from find-package
+ (if (string= string "SB!XC")
+ (find-package "COMMON-LISP")
+ (find-package
+ (substitute #\- #\! string :count 1)))))))
+ packageoid)))
(typecase package-designator
(package package-designator)
(symbol (find-package-from-string (symbol-name package-designator)))
(string (find-package-from-string package-designator))
(character (find-package-from-string (string package-designator)))
(t (error 'type-error
- :datum package-designator
- :expected-type '(or character package string symbol))))))
+ :datum package-designator
+ :expected-type '(or character package string symbol))))))
;;; Return a list of packages given a package designator or list of
;;; package designators, or die trying.
;;; Make a package name into a simple-string.
(defun package-namify (n)
- (stringify-name n "package"))
+ (stringify-package-designator n))
;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME
;;; returns NIL (not an error) for a deleted package, so this is a special
;;; must be between 2 and 255.
(defmacro entry-hash (length sxhash)
`(the fixnum
- (+ (the fixnum
- (rem (the fixnum
- (logxor ,length
- ,sxhash
- (the fixnum (ash ,sxhash -8))
- (the fixnum (ash ,sxhash -16))
- (the fixnum (ash ,sxhash -19))))
- 254))
- 2)))
+ (+ (the fixnum
+ (rem (the fixnum
+ (logxor ,length
+ ,sxhash
+ (the fixnum (ash ,sxhash -8))
+ (the fixnum (ash ,sxhash -16))
+ (the fixnum (ash ,sxhash -19))))
+ 254))
+ 2)))
;;; FIXME: should be wrapped in EVAL-WHEN (COMPILE EXECUTE)
;;; Add a symbol to a package hashtable. The symbol is assumed
;;; not to be present.
(defun add-symbol (table symbol)
+ (when (zerop (package-hashtable-free table))
+ ;; The hashtable is full. Resize it to be able to hold twice the
+ ;; amount of symbols than it currently contains. The actual new size
+ ;; can be smaller than twice the current size if the table contained
+ ;; deleted entries.
+ (resize-package-hashtable table
+ (* (- (package-hashtable-size table)
+ (package-hashtable-deleted table))
+ 2)))
(let* ((vec (package-hashtable-table table))
- (hash (package-hashtable-hash table))
- (len (length vec))
- (sxhash (%sxhash-simple-string (symbol-name symbol)))
- (h2 (the fixnum (1+ (the fixnum (rem sxhash
- (the fixnum (- len 2))))))))
- (declare (fixnum len sxhash h2))
- (cond ((zerop (the fixnum (package-hashtable-free table)))
- (make-or-remake-package-hashtable (* (package-hashtable-size table)
- 2)
- table)
- (add-symbol table symbol)
- (dotimes (i len)
- (declare (fixnum i))
- (when (> (the fixnum (aref hash i)) 1)
- (add-symbol table (svref vec i)))))
- (t
- (do ((i (rem sxhash len) (rem (+ i h2) len)))
- ((< (the fixnum (aref hash i)) 2)
- (if (zerop (the fixnum (aref hash i)))
- (decf (package-hashtable-free table))
- (decf (package-hashtable-deleted table)))
- (setf (svref vec i) symbol)
- (setf (aref hash i)
- (entry-hash (length (symbol-name symbol))
- sxhash)))
- (declare (fixnum i)))))))
+ (hash (package-hashtable-hash table))
+ (len (length vec))
+ (sxhash (%sxhash-simple-string (symbol-name symbol)))
+ (h2 (1+ (rem sxhash (- len 2)))))
+ (declare (fixnum sxhash h2))
+ (do ((i (rem sxhash len) (rem (+ i h2) len)))
+ ((< (the fixnum (aref hash i)) 2)
+ (if (zerop (the fixnum (aref hash i)))
+ (decf (package-hashtable-free table))
+ (decf (package-hashtable-deleted table)))
+ (setf (svref vec i) symbol)
+ (setf (aref hash i)
+ (entry-hash (length (symbol-name symbol))
+ sxhash)))
+ (declare (fixnum i)))))
+
+;;; Resize the package hashtables of all packages so that their load
+;;; factor is +PACKAGE-HASHTABLE-IMAGE-LOAD-FACTOR+. Called from
+;;; SAVE-LISP-AND-DIE to optimize space usage in the image.
+(defun tune-hashtable-sizes-of-all-packages ()
+ (flet ((tune-table-size (table)
+ (resize-package-hashtable
+ table
+ (round (* (/ +package-rehash-threshold+
+ +package-hashtable-image-load-factor+)
+ (- (package-hashtable-size table)
+ (package-hashtable-free table)
+ (package-hashtable-deleted table)))))))
+ (dolist (package (list-all-packages))
+ (tune-table-size (package-internal-symbols package))
+ (tune-table-size (package-external-symbols package)))))
;;; 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)
+ entry-hash)
+ &body forms)
(let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
- (name (gensym)) (name-len (gensym)) (ehash (gensym)))
+ (name (gensym)) (name-len (gensym)) (ehash (gensym)))
`(let* ((,vec (package-hashtable-table ,table))
- (,hash (package-hashtable-hash ,table))
- (,len (length ,vec))
- (,h2 (1+ (the index (rem (the index ,sxhash)
- (the index (- ,len 2)))))))
+ (,hash (package-hashtable-hash ,table))
+ (,len (length ,vec))
+ (,h2 (1+ (the index (rem (the hash ,sxhash)
+ (the index (- ,len 2)))))))
(declare (type index ,len ,h2))
- (prog ((,index-var (rem (the index ,sxhash) ,len))
- ,symbol-var ,ehash)
- (declare (type (or index null) ,index-var))
- LOOP
- (setq ,ehash (aref ,hash ,index-var))
- (cond ((eql ,ehash ,entry-hash)
- (setq ,symbol-var (svref ,vec ,index-var))
- (let* ((,name (symbol-name ,symbol-var))
- (,name-len (length ,name)))
- (declare (type index ,name-len))
- (when (and (= ,name-len ,length)
- (string= ,string ,name
- :end1 ,length
- :end2 ,name-len))
- (go DOIT))))
- ((zerop ,ehash)
- (setq ,index-var nil)
- (go DOIT)))
- (setq ,index-var (+ ,index-var ,h2))
- (when (>= ,index-var ,len)
- (setq ,index-var (- ,index-var ,len)))
- (go LOOP)
- DOIT
- (return (progn ,@forms))))))
+ (prog ((,index-var (rem (the hash ,sxhash) ,len))
+ ,symbol-var ,ehash)
+ (declare (type (or index null) ,index-var))
+ LOOP
+ (setq ,ehash (aref ,hash ,index-var))
+ (cond ((eql ,ehash ,entry-hash)
+ (setq ,symbol-var (svref ,vec ,index-var))
+ (let* ((,name (symbol-name ,symbol-var))
+ (,name-len (length ,name)))
+ (declare (type index ,name-len))
+ (when (and (= ,name-len ,length)
+ (string= ,string ,name
+ :end1 ,length
+ :end2 ,name-len))
+ (go DOIT))))
+ ((zerop ,ehash)
+ (setq ,index-var nil)
+ (go DOIT)))
+ (setq ,index-var (+ ,index-var ,h2))
+ (when (>= ,index-var ,len)
+ (setq ,index-var (- ,index-var ,len)))
+ (go LOOP)
+ DOIT
+ (return (progn ,@forms))))))
;;; Delete the entry for STRING in TABLE. The entry must exist.
(defun nuke-symbol (table string)
(declare (simple-string string))
(let* ((length (length string))
- (hash (%sxhash-simple-string string))
- (ehash (entry-hash length hash)))
- (declare (type index length hash))
+ (hash (%sxhash-simple-string string))
+ (ehash (entry-hash length hash)))
+ (declare (type index length)
+ (type hash hash))
(with-symbol (index symbol table string length hash ehash)
(setf (aref (package-hashtable-hash table) index) 1)
(setf (aref (package-hashtable-table table) index) nil)
- (incf (package-hashtable-deleted table)))))
+ (incf (package-hashtable-deleted table))))
+ ;; If the table is less than one quarter full, halve its size and
+ ;; rehash the entries.
+ (let* ((size (package-hashtable-size table))
+ (deleted (package-hashtable-deleted table))
+ (used (- size
+ (package-hashtable-free table)
+ deleted)))
+ (declare (type fixnum size deleted used))
+ (when (< used (truncate size 4))
+ (resize-package-hashtable table (* used 2)))))
\f
-;;; 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)
+;;; 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. Caller is
+;;; responsible for having acquired the mutex via WITH-PACKAGES.
+(defun %enter-new-nicknames (package nicknames)
(declare (type list nicknames))
(dolist (n nicknames)
(let* ((n (package-namify n))
- (found (gethash n *package-names*)))
- (cond ((not found)
- (setf (gethash n *package-names*) package)
- (push n (package-%nicknames package)))
- ((eq found package))
- ((string= (the string (package-%name found)) n)
+ (found (with-package-names (names)
+ (or (gethash n names)
+ (progn
+ (setf (gethash n names) package)
+ (push n (package-%nicknames package))
+ package)))))
+ (cond ((eq found package))
+ ((string= (the string (package-%name found)) n)
(cerror "Ignore this nickname."
- 'simple-package-error
- :package package
- :format-control "~S is a package name, so it cannot be a nickname for ~S."
- :format-arguments (list n (package-%name package))))
- (t
+ 'simple-package-error
+ :package package
+ :format-control "~S is a package name, so it cannot be a nickname for ~S."
+ :format-arguments (list n (package-%name package))))
+ (t
(cerror "Leave this nickname alone."
- 'simple-package-error
- :package package
- :format-control "~S is already a nickname for ~S."
- :format-arguments (list n (package-%name found))))))))
+ 'simple-package-error
+ :package package
+ :format-control "~S is already a nickname for ~S."
+ :format-arguments (list n (package-%name found))))))))
(defun make-package (name &key
- (use '#.*default-package-use-list*)
- nicknames
- (internal-symbols 10)
- (external-symbols 10))
+ (use '#.*default-package-use-list*)
+ nicknames
+ (internal-symbols 10)
+ (external-symbols 10))
#!+sb-doc
#.(format nil
- "Make a new package having the specified NAME, NICKNAMES, and
- USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are
- estimates for the number of internal and external symbols which
- will ultimately be present in the package. The default value of
- USE is implementation-dependent, and in this implementation
- it is ~S."
- *default-package-use-list*)
-
- ;; Check for package name conflicts in name and nicknames, then
- ;; make the package.
- (when (find-package name)
- ;; ANSI specifies that this error is correctable.
- (cerror "Leave existing package alone."
- "A package named ~S already exists" name))
- (let* ((name (package-namify name))
- (package (internal-make-package
- :%name name
- :internal-symbols (make-or-remake-package-hashtable
- internal-symbols)
- :external-symbols (make-or-remake-package-hashtable
- external-symbols))))
-
- ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
- ;; conflicting exports among used packages is done.
- (if *in-package-init*
- (push (list use package) *!deferred-use-packages*)
- (use-package use package))
-
- ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
- ;; which would leave us with possibly-bad side effects from the earlier
- ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
- ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
- ;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before
- ;; USE-PACKAGE, but I need to check what kinds of errors can be caused by
- ;; USE-PACKAGE, too.
- (enter-new-nicknames package nicknames)
- (setf (gethash name *package-names*) package)))
+ "Make a new package having the specified NAME, NICKNAMES, and USE
+list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are estimates for the number of
+internal and external symbols which will ultimately be present in the package.
+The default value of USE is implementation-dependent, and in this
+implementation it is ~S." *default-package-use-list*)
+ (prog (clobber)
+ :restart
+ (when (find-package name)
+ ;; ANSI specifies that this error is correctable.
+ (cerror "Clobber existing package."
+ "A package named ~S already exists" name)
+ (setf clobber t))
+ (with-packages ()
+ ;; Check for race, signal the error outside the lock.
+ (when (and (not clobber) (find-package name))
+ (go :restart))
+ (let* ((name (package-namify name))
+ (package (internal-make-package
+ :%name name
+ :internal-symbols (make-or-remake-package-hashtable
+ internal-symbols)
+ :external-symbols (make-or-remake-package-hashtable
+ external-symbols))))
+
+ ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
+ ;; conflicting exports among used packages is done.
+ (if *in-package-init*
+ (push (list use package) *!deferred-use-packages*)
+ (use-package use package))
+
+ ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
+ ;; which would leave us with possibly-bad side effects from the earlier
+ ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
+ ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
+ ;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before
+ ;; USE-PACKAGE, but I need to check what kinds of errors can be caused by
+ ;; USE-PACKAGE, too.
+ (%enter-new-nicknames package nicknames)
+ (return (setf (gethash name *package-names*) package))))
+ (bug "never")))
;;; Change the name if we can, blast any old nicknames and then
;;; add in any new ones.
;;; the package name if NAME is the same package that's referred to by PACKAGE.
;;; If it's a *different* package, we should probably signal an error.
;;; (perhaps (ERROR 'ANSI-WEIRDNESS ..):-)
-(defun rename-package (package name &optional (nicknames ()))
+(defun rename-package (package-designator name &optional (nicknames ()))
#!+sb-doc
"Changes the name and nicknames for a package."
- (let* ((package (find-undeleted-package-or-lose package))
- (name (package-namify name))
- (found (find-package name))
- (nicks (mapcar #'string nicknames)))
- (unless (or (not found) (eq found package))
- (error 'simple-package-error
- :package name
- :format-control "A package named ~S already exists."
- :format-arguments (list name)))
- (with-single-package-locked-error ()
- (unless (and (string= name (package-name package))
- (null (set-difference nicks (package-nicknames package)
- :test #'string=)))
- (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
- ~{~A~^, ~}~]"
- name (length nicks) nicks))
- ;; do the renaming
- (remhash (package-%name package) *package-names*)
- (dolist (n (package-%nicknames package))
- (remhash n *package-names*))
- (setf (package-%name package) name
- (gethash name *package-names*) package
- (package-%nicknames package) ())
- (enter-new-nicknames package nicknames))
+ (let ((package nil))
+ (tagbody :restart
+ (setq package (find-undeleted-package-or-lose package-designator))
+ (let* ((name (package-namify name))
+ (found (find-package name))
+ (nicks (mapcar #'string nicknames)))
+ (unless (or (not found) (eq found package))
+ (error 'simple-package-error
+ :package name
+ :format-control "A package named ~S already exists."
+ :format-arguments (list name)))
+ (with-single-package-locked-error ()
+ (unless (and (string= name (package-name package))
+ (null (set-difference nicks (package-nicknames package)
+ :test #'string=)))
+ (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
+ ~{~A~^, ~}~]"
+ name (length nicks) nicks))
+ (with-package-names (names)
+ ;; Check for race conditions now that we have the lock.
+ (unless (eq package (find-package package-designator))
+ (go :restart))
+ ;; Do the renaming.
+ (remhash (package-%name package) names)
+ (dolist (n (package-%nicknames package))
+ (remhash n names))
+ (setf (package-%name package) name
+ (gethash name names) package
+ (package-%nicknames package) ()))
+ (%enter-new-nicknames package nicknames))))
package))
(defun delete-package (package-designator)
#!+sb-doc
"Delete the package designated by PACKAGE-DESIGNATOR from the package
system data structures."
- (let ((package (if (packagep package-designator)
- package-designator
- (find-package package-designator))))
- (cond ((not package)
- ;; This continuable error is required by ANSI.
- (cerror
- "Return ~S."
- (make-condition
- 'simple-package-error
- :package package-designator
- :format-control "There is no package named ~S."
- :format-arguments (list package-designator))
- nil))
- ((not (package-name package)) ; already deleted
- nil)
- (t
- (with-single-package-locked-error
- (:package package "deleting package ~A" package)
- (let ((use-list (package-used-by-list package)))
- (when use-list
- ;; This continuable error is specified by ANSI.
- (cerror
- "Remove dependency in other packages."
- (make-condition
- 'simple-package-error
- :package package
- :format-control
- "~@<Package ~S is used by package~P:~2I~_~S~@:>"
- :format-arguments (list (package-name package)
- (length use-list)
- (mapcar #'package-name use-list))))
- (dolist (p use-list)
- (unuse-package package p))))
- (dolist (used (package-use-list package))
- (unuse-package used package))
- (do-symbols (sym package)
- (unintern sym package))
- (remhash (package-name package) *package-names*)
- (dolist (nick (package-nicknames package))
- (remhash nick *package-names*))
- (setf (package-%name package) nil
- ;; Setting PACKAGE-%NAME to NIL is required in order to
- ;; make PACKAGE-NAME return NIL for a deleted package as
- ;; ANSI requires. Setting the other slots to NIL
- ;; and blowing away the PACKAGE-HASHTABLES is just done
- ;; for tidiness and to help the GC.
- (package-%nicknames package) nil
- (package-%use-list package) nil
- (package-tables package) nil
- (package-%shadowing-symbols package) nil
- (package-internal-symbols package)
- (make-or-remake-package-hashtable 0)
- (package-external-symbols package)
- (make-or-remake-package-hashtable 0))
- t)))))
+ (tagbody :restart
+ (let ((package (find-package package-designator)))
+ (cond ((not package)
+ ;; This continuable error is required by ANSI.
+ (cerror
+ "Return ~S."
+ (make-condition
+ 'simple-package-error
+ :package package-designator
+ :format-control "There is no package named ~S."
+ :format-arguments (list package-designator))
+ (return-from delete-package nil)))
+ ((not (package-name package)) ; already deleted
+ (return-from delete-package nil))
+ (t
+ (with-single-package-locked-error
+ (:package package "deleting package ~A" package)
+ (let ((use-list (package-used-by-list package)))
+ (when use-list
+ ;; This continuable error is specified by ANSI.
+ (cerror
+ "Remove dependency in other packages."
+ (make-condition
+ 'simple-package-error
+ :package package
+ :format-control
+ "~@<Package ~S is used by package~P:~2I~_~S~@:>"
+ :format-arguments (list (package-name package)
+ (length use-list)
+ (mapcar #'package-name use-list))))
+ (dolist (p use-list)
+ (unuse-package package p))))
+ (with-package-graph ()
+ ;; Check for races, restart if necessary.
+ (let ((package2 (find-package package-designator)))
+ (when (or (neq package package2) (package-used-by-list package2))
+ (go :restart)))
+ (dolist (used (package-use-list package))
+ (unuse-package used package))
+ (do-symbols (sym package)
+ (unintern sym package))
+ (with-package-names (names)
+ (remhash (package-name package) names)
+ (dolist (nick (package-nicknames package))
+ (remhash nick names))
+ (setf (package-%name package) nil
+ ;; Setting PACKAGE-%NAME to NIL is required in order to
+ ;; make PACKAGE-NAME return NIL for a deleted package as
+ ;; ANSI requires. Setting the other slots to NIL
+ ;; and blowing away the PACKAGE-HASHTABLES is just done
+ ;; for tidiness and to help the GC.
+ (package-%nicknames package) nil))
+ (setf (package-%use-list package) nil
+ (package-tables package) nil
+ (package-%shadowing-symbols package) nil
+ (package-internal-symbols package)
+ (make-or-remake-package-hashtable 0)
+ (package-external-symbols package)
+ (make-or-remake-package-hashtable 0)))
+ (return-from delete-package t)))))))
(defun list-all-packages ()
#!+sb-doc
"Return a list of all existing packages."
(let ((res ()))
- (maphash (lambda (k v)
- (declare (ignore k))
- (pushnew v res))
- *package-names*)
+ (with-package-names (names)
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (pushnew v res))
+ names))
res))
\f
(defun intern (name &optional (package (sane-package)))
;; We just simple-stringify the name and call INTERN*, where the real
;; logic is.
(let ((name (if (simple-string-p name)
- name
- (coerce name 'simple-string)))
- (package (find-undeleted-package-or-lose package)))
+ name
+ (coerce name 'simple-string)))
+ (package (find-undeleted-package-or-lose package)))
(declare (simple-string name))
(intern* name
- (length name)
- package)))
+ (length name)
+ package)))
(defun find-symbol (name &optional (package (sane-package)))
#!+sb-doc
(let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
(declare (simple-string name))
(find-symbol* name
- (length name)
- (find-undeleted-package-or-lose package))))
+ (length name)
+ (find-undeleted-package-or-lose package))))
;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
;;; then create it, special-casing the keyword package.
(declare (simple-string name))
(multiple-value-bind (symbol where) (find-symbol* name length package)
(cond (where
- (values symbol where))
- (t
- (let ((symbol-name (subseq name 0 length)))
- (with-single-package-locked-error
- (:package package "interning ~A" symbol-name)
- (let ((symbol (make-symbol symbol-name)))
- (%set-symbol-package symbol package)
- (cond ((eq package *keyword-package*)
- (add-symbol (package-external-symbols package) symbol)
- (%set-symbol-value symbol symbol))
- (t
- (add-symbol (package-internal-symbols package) symbol)))
- (values symbol nil))))))))
+ (values symbol where))
+ (t
+ ;; Let's try again with a lock: the common case has the
+ ;; symbol already interned, handled by the first leg of the
+ ;; COND, but in case another thread is interning in
+ ;; parallel we need to check after grabbing the lock.
+ (with-package-graph ()
+ (setf (values symbol where) (find-symbol* name length package))
+ (if where
+ (values symbol where)
+ (let ((symbol-name (subseq name 0 length)))
+ (with-single-package-locked-error
+ (:package package "interning ~A" symbol-name)
+ (let ((symbol (make-symbol symbol-name)))
+ (%set-symbol-package symbol package)
+ (cond
+ ((eq package *keyword-package*)
+ (%set-symbol-value symbol symbol)
+ (add-symbol (package-external-symbols package) symbol))
+ (t
+ (add-symbol (package-internal-symbols package) symbol)))
+ (values symbol nil))))))))))
;;; Check internal and external symbols, then scan down the list
-;;; of hashtables for inherited symbols. When an inherited symbol
-;;; is found pull that table to the beginning of the list.
+;;; of hashtables for inherited symbols.
(defun find-symbol* (string length package)
(declare (simple-string string)
- (type index length))
+ (type index length))
(let* ((hash (%sxhash-simple-substring string length))
- (ehash (entry-hash length hash)))
- (declare (type index hash ehash))
+ (ehash (entry-hash length hash)))
+ (declare (type hash hash ehash))
(with-symbol (found symbol (package-internal-symbols package)
- string length hash ehash)
+ string length hash ehash)
(when found
- (return-from find-symbol* (values symbol :internal))))
+ (return-from find-symbol* (values symbol :internal))))
(with-symbol (found symbol (package-external-symbols package)
- string length hash ehash)
+ string length hash ehash)
(when found
- (return-from find-symbol* (values symbol :external))))
+ (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))))))))
+ (table (cdr head) (cdr table)))
+ ((null table) (values nil nil))
+ (with-symbol (found symbol (car table) string length hash ehash)
+ (when found
+ ;; At this point we used to move the table to the
+ ;; beginning of the list, probably on the theory that we'd
+ ;; soon be looking up further items there. Unfortunately
+ ;; that was very much non-thread safe. Since the failure
+ ;; mode was nasty (corruption of the package in a way
+ ;; which would make symbol lookups loop infinitely) and it
+ ;; would be triggered just by doing reads to a resource
+ ;; that users can't do their own locking on, that code has
+ ;; been removed. If we ever add locking to packages,
+ ;; resurrecting that code might make sense, even though it
+ ;; didn't seem to have much of an performance effect in
+ ;; normal use.
+ ;;
+ ;; -- JES, 2006-09-13
+ (return-from find-symbol* (values symbol :inherited))))))))
;;; Similar to FIND-SYMBOL, but only looks for an external symbol.
;;; This is used for fast name-conflict checking in this file and symbol
(defun find-external-symbol (string package)
(declare (simple-string string))
(let* ((length (length string))
- (hash (%sxhash-simple-string string))
- (ehash (entry-hash length hash)))
- (declare (type index length hash))
+ (hash (%sxhash-simple-string string))
+ (ehash (entry-hash length hash)))
+ (declare (type index length)
+ (type hash hash))
(with-symbol (found symbol (package-external-symbols package)
- string length hash ehash)
+ string length hash ehash)
(values symbol found))))
\f
+(defun print-symbol-with-prefix (stream symbol colon at)
+ #!+sb-doc
+ "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
+ the current package."
+ (declare (ignore colon at))
+ ;; Only keywords should be accessible from the keyword package, and
+ ;; keywords are always printed with colons, so this guarantees that the
+ ;; symbol will not be printed without a prefix.
+ (let ((*package* *keyword-package*))
+ (write symbol :stream stream :escape t)))
+
(define-condition name-conflict (reference-condition package-error)
((function :initarg :function :reader name-conflict-function)
(datum :initarg :datum :reader name-conflict-datum)
(:report
(lambda (c s)
(format s "~@<~S ~S causes name-conflicts in ~S between the ~
- following symbols:~2I~@:_~{~S~^, ~}~:@>"
+ following symbols:~2I~@:_~
+ ~{~/sb-impl::print-symbol-with-prefix/~^, ~}~:@>"
(name-conflict-function c)
(name-conflict-datum c)
(package-error-package c)
(restart-case
(error 'name-conflict :package package :symbols symbols
:function function :datum datum)
- (resolve-conflict (s)
+ (resolve-conflict (chosen-symbol)
:report "Resolve conflict."
:interactive
(lambda ()
(let* ((len (length symbols))
- (nlen (length (write-to-string len :base 10))))
+ (nlen (length (write-to-string len :base 10)))
+ (*print-pretty* t))
(format *query-io* "~&~@<Select a symbol to be made accessible in ~
- package ~A:~2I~@:_~{~{~V,' D. ~S~}~@:_~}~@:>"
+ package ~A:~2I~@:_~{~{~V,' D. ~
+ ~/sb-impl::print-symbol-with-prefix/~}~@:_~}~
+ ~@:>"
(package-name package)
(loop for s in symbols
for i upfrom 1
(let ((i (parse-integer (read-line *query-io*) :junk-allowed t)))
(when (and i (<= 1 i len))
(return (list (nth (1- i) symbols))))))))
- (multiple-value-bind (symbol status)
- (find-symbol (symbol-name s) package)
- (declare (ignore status)) ; FIXME: is that true?
- (case function
- ((export)
- (if (eq symbol s)
- (shadow symbol package)
- (unintern symbol package)))
- ((unintern)
- (shadowing-import s package))
- ((import)
- (if (eq symbol s)
- nil ; do nothing
- (shadowing-import s package)))
- ((use-package)
- (if (eq symbol s)
- (shadow s package)
- (shadowing-import s package))))))))
-
-#+nil ; this solution gives a variable number of restarts instead, but
- ; no good way of programmatically choosing between them.
-(defun name-conflict (package function datum &rest symbols)
- (let ((condition (make-condition 'name-conflict
- :package package :symbols symbols
- :function function :datum datum)))
- ;; this is a gross violation of modularity, but I can't see any
- ;; other way to have a variable number of restarts.
- (let ((*restart-clusters*
- (cons
- (mapcan
- (lambda (s)
- (multiple-value-bind (accessible-symbol status)
- (find-symbol (symbol-name s) package)
- (cond
- ;; difficult case
- ((eq s accessible-symbol)
- (ecase status
- ((:inherited)
- (list (make-restart
- :name (make-symbol "SHADOWING-IMPORT")
- :function (lambda ()
- (shadowing-import s package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream "Shadowing-import ~S into ~A."
- s (package-%name package))))))
- ((:internal :external)
- (aver (= (length symbols) 2))
- ;; ARGH! FIXME: this unintern restart can
- ;; _still_ leave the system in an
- ;; unsatisfactory state: if the symbol is a
- ;; external symbol of a package which is
- ;; already used by this package, and has also
- ;; been imported, then uninterning it from this
- ;; package will still leave it visible!
- ;;
- ;; (DEFPACKAGE "FOO" (:EXPORT "SYM"))
- ;; (DEFPACKAGE "BAR" (:EXPORT "SYM"))
- ;; (DEFPACKAGE "BAZ" (:USE "FOO"))
- ;; (IMPORT 'FOO:SYM "BAZ")
- ;; (USE-PACKAGE "BAR" "BAZ")
- ;;
- ;; Now (UNINTERN 'FOO:SYM "BAZ") doesn't
- ;; resolve the conflict. :-(
- ;;
- ;; -- CSR, 2004-10-20
- (list (make-restart
- :name (make-symbol "UNINTERN")
- :function (lambda ()
- (unintern s package)
- (import
- (find s symbols :test-not #'eq)
- package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream
- "Unintern ~S from ~A and import ~S."
- s
- (package-%name package)
- (find s symbols :test-not #'eq))))))))
- (t (list (make-restart
- :name (make-symbol "SHADOWING-IMPORT")
- :function (lambda ()
- (shadowing-import s package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream "Shadowing-import ~S into ~A."
- s (package-%name package)))))))))
- symbols)
- *restart-clusters*)))
- (with-condition-restarts condition (car *restart-clusters*)
- (with-simple-restart (abort "Leave action undone.")
- (error condition))))))
+ (multiple-value-bind (package-symbol status)
+ (find-symbol (symbol-name chosen-symbol) package)
+ (let* ((accessiblep status) ; never NIL here
+ (presentp (and accessiblep
+ (not (eq :inherited status)))))
+ (ecase function
+ ((unintern)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ (shadow (list package-symbol) package)
+ (shadowing-import (list chosen-symbol) package))
+ (shadowing-import (list chosen-symbol) package)))
+ ((use-package export)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5
+ (if (eq (symbol-package package-symbol) package)
+ (unintern package-symbol package) ; CLHS 11.1.1.2.5
+ (shadowing-import (list chosen-symbol) package)))
+ (shadowing-import (list chosen-symbol) package)))
+ ((import)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ nil ; re-importing the same symbol
+ (shadowing-import (list chosen-symbol) package))
+ (shadowing-import (list chosen-symbol) package)))))))))
;;; If we are uninterning a shadowing symbol, then a name conflict can
;;; result, otherwise just nuke the symbol.
(defun unintern (symbol &optional (package (sane-package)))
#!+sb-doc
- "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present
- then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home
- package, then it is made uninterned."
- (let* ((package (find-undeleted-package-or-lose package))
- (name (symbol-name symbol))
- (shadowing-symbols (package-%shadowing-symbols package)))
- (declare (list shadowing-symbols))
-
- (with-single-package-locked-error ()
- (when (find-symbol name package)
- (assert-package-unlocked package "uninterning ~A" name))
-
- ;; If a name conflict is revealed, give us a chance to
- ;; shadowing-import one of the accessible symbols.
- (when (member symbol shadowing-symbols)
- (let ((cset ()))
- (dolist (p (package-%use-list package))
- (multiple-value-bind (s w) (find-external-symbol name p)
- (when w (pushnew s cset))))
- (when (cdr cset)
- (apply #'name-conflict package 'unintern symbol cset)
- (return-from unintern t)))
- (setf (package-%shadowing-symbols package)
- (remove symbol shadowing-symbols)))
-
- (multiple-value-bind (s w) (find-symbol name package)
- (declare (ignore s))
- (cond ((or (eq w :internal) (eq w :external))
- (nuke-symbol (if (eq w :internal)
- (package-internal-symbols package)
- (package-external-symbols package))
- name)
- (if (eq (symbol-package symbol) package)
- (%set-symbol-package symbol nil))
- t)
- (t nil))))))
+ "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."
+ (with-package-graph ()
+ (let* ((package (find-undeleted-package-or-lose package))
+ (name (symbol-name symbol))
+ (shadowing-symbols (package-%shadowing-symbols package)))
+ (declare (list shadowing-symbols))
+
+ (with-single-package-locked-error ()
+ (when (find-symbol name package)
+ (assert-package-unlocked package "uninterning ~A" name))
+
+ ;; If a name conflict is revealed, give us a chance to
+ ;; shadowing-import one of the accessible symbols.
+ (when (member symbol shadowing-symbols)
+ (let ((cset ()))
+ (dolist (p (package-%use-list package))
+ (multiple-value-bind (s w) (find-external-symbol name p)
+ (when w (pushnew s cset))))
+ (when (cdr cset)
+ (apply #'name-conflict package 'unintern symbol cset)
+ (return-from unintern t)))
+ (setf (package-%shadowing-symbols package)
+ (remove symbol shadowing-symbols)))
+
+ (multiple-value-bind (s w) (find-symbol name package)
+ (declare (ignore s))
+ (cond ((or (eq w :internal) (eq w :external))
+ (nuke-symbol (if (eq w :internal)
+ (package-internal-symbols package)
+ (package-external-symbols package))
+ name)
+ (if (eq (symbol-package symbol) package)
+ (%set-symbol-package symbol nil))
+ t)
+ (t nil)))))))
\f
;;; 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))))
+ (dolist (s thing)
+ (unless (symbolp s) (error "~S is not a symbol." s)))
+ thing)
+ ((symbolp thing) (list thing))
+ (t
+ (error "~S is neither a symbol nor a list of symbols." thing))))
(defun string-listify (thing)
- (mapcar #'string (if (listp thing)
- thing
- (list thing))))
+ (mapcar #'string (if (listp thing)
+ thing
+ (list thing))))
;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
;;; down the package it is inherited from and uninterns it there. Used
(defun moby-unintern (symbol package)
(unless (member symbol (package-%shadowing-symbols package))
(or (unintern symbol package)
- (let ((name (symbol-name symbol)))
- (multiple-value-bind (s w) (find-symbol name package)
- (declare (ignore s))
- (when (eq w :inherited)
- (dolist (q (package-%use-list package))
- (multiple-value-bind (u x) (find-external-symbol name q)
- (declare (ignore u))
- (when x
- (unintern symbol q)
- (return t))))))))))
+ (let ((name (symbol-name symbol)))
+ (multiple-value-bind (s w) (find-symbol name package)
+ (declare (ignore s))
+ (when (eq w :inherited)
+ (dolist (q (package-%use-list package))
+ (multiple-value-bind (u x) (find-external-symbol name q)
+ (declare (ignore u))
+ (when x
+ (unintern symbol q)
+ (return t))))))))))
\f
(defun export (symbols &optional (package (sane-package)))
#!+sb-doc
"Exports SYMBOLS from PACKAGE, checking that no name conflicts result."
- (let ((package (find-undeleted-package-or-lose package))
- (syms ()))
- ;; Punt any symbols that are already external.
- (dolist (sym (symbol-listify symbols))
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) package)
- (declare (ignore s))
- (unless (or w (member sym syms))
- (push sym syms))))
- (with-single-package-locked-error ()
- (when syms
- (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
- (length syms) syms))
- ;; Find symbols and packages with conflicts.
- (let ((used-by (package-%used-by-list package))
- (cset ()))
- (dolist (sym syms)
- (let ((name (symbol-name sym)))
- (dolist (p used-by)
- (multiple-value-bind (s w) (find-symbol name p)
- (when (and w
- (not (eq s sym))
- (not (member s (package-%shadowing-symbols p))))
- ;; Beware: the name conflict is in package P, not in
- ;; PACKAGE.
- (name-conflict p 'export sym sym s)
- (pushnew sym cset))))))
- (when cset
- (setq syms (set-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
- "~S these symbols into the ~A package."
- (make-condition
- 'simple-package-error
- :package package
- :format-control
- "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
- :format-arguments (list (package-%name package) missing))
- 'import (package-%name package))
- (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))
+ (with-package-graph ()
+ (let ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
+ (syms ()))
+ ;; Punt any symbols that are already external.
+ (dolist (sym symbols)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) package)
+ (declare (ignore s))
+ (unless (or w (member sym syms))
+ (push sym syms))))
+ (with-single-package-locked-error ()
+ (when syms
+ (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
+ (length syms) syms))
+ ;; Find symbols and packages with conflicts.
+ (let ((used-by (package-%used-by-list package)))
+ (dolist (sym syms)
+ (let ((name (symbol-name sym)))
+ (dolist (p used-by)
+ (multiple-value-bind (s w) (find-symbol name p)
+ (when (and w
+ (not (eq s sym))
+ (not (member s (package-%shadowing-symbols p))))
+ ;; Beware: the name conflict is in package P, not in
+ ;; PACKAGE.
+ (name-conflict p 'export sym sym s)))))))
+ ;; 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
+ "~S these symbols into the ~A package."
+ (make-condition
+ 'simple-package-error
+ :package package
+ :format-control
+ "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
+ :format-arguments (list (package-%name package) missing))
+ 'import (package-%name package))
+ (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)))
\f
;;; Check that all symbols are accessible, then move from external to internal.
(defun unexport (symbols &optional (package (sane-package)))
#!+sb-doc
"Makes SYMBOLS no longer exported from PACKAGE."
- (let ((package (find-undeleted-package-or-lose package))
- (syms ()))
- (dolist (sym (symbol-listify symbols))
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (cond ((or (not w) (not (eq s sym)))
- (error 'simple-package-error
- :package package
- :format-control "~S is not accessible in the ~A package."
- :format-arguments (list sym (package-%name package))))
- ((eq w :external) (pushnew sym syms)))))
- (with-single-package-locked-error ()
- (when syms
- (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
- (length syms) syms))
- (let ((internal (package-internal-symbols package))
- (external (package-external-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)
- (nuke-symbol external (symbol-name sym)))))
- t))
+ (with-package-graph ()
+ (let ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
+ (syms ()))
+ (dolist (sym symbols)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((or (not w) (not (eq s sym)))
+ (error 'simple-package-error
+ :package package
+ :format-control "~S is not accessible in the ~A package."
+ :format-arguments (list sym (package-%name package))))
+ ((eq w :external) (pushnew sym syms)))))
+ (with-single-package-locked-error ()
+ (when syms
+ (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
+ (length syms) syms))
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)
+ (nuke-symbol external (symbol-name sym)))))
+ t)))
\f
;;; Check for name conflict caused by the import and let the user
;;; shadowing-import if there is.
(defun import (symbols &optional (package (sane-package)))
#!+sb-doc
- "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol
- is already accessible then it has no effect. If a name conflict
- would result from the importation, then a correctable error is signalled."
- (let* ((package (find-undeleted-package-or-lose package))
- (symbols (symbol-listify symbols))
- (homeless (remove-if #'symbol-package symbols))
- (syms ()))
- (with-single-package-locked-error ()
- (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))
- (name-conflict package 'import sym sym (car found)))
- (push sym syms))))
- ((not (eq s sym))
- (name-conflict package 'import sym sym s))
- ((eq w :inherited) (push sym syms)))))
- (when (or homeless syms)
- (let ((union (delete-duplicates (append homeless syms))))
- (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}"
- (length union) union)))
- ;; Add the new symbols to the internal hashtable.
- (let ((internal (package-internal-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)))
- ;; If any of the symbols are uninterned, make them be owned by PACKAGE.
- (dolist (sym homeless)
- (%set-symbol-package sym package))
- t)))
+ "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."
+ (with-package-graph ()
+ (let* ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
+ (homeless (remove-if #'symbol-package symbols))
+ (syms ()))
+ (with-single-package-locked-error ()
+ (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))
+ (setf syms (remove (car found) syms))
+ (name-conflict package 'import sym sym (car found)))
+ (push sym syms))))
+ ((not (eq s sym))
+ (name-conflict package 'import sym sym s))
+ ((eq w :inherited) (push sym syms)))))
+ (when (or homeless syms)
+ (let ((union (delete-duplicates (append homeless syms))))
+ (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}"
+ (length union) union)))
+ ;; Add the new symbols to the internal hashtable.
+ (let ((internal (package-internal-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)))
+ ;; If any of the symbols are uninterned, make them be owned by PACKAGE.
+ (dolist (sym homeless)
+ (%set-symbol-package sym package))
+ t))))
\f
;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
#!+sb-doc
"Import SYMBOLS into package, disregarding any name conflict. If
a symbol of the same name is present, then it is uninterned."
- (let* ((package (find-undeleted-package-or-lose package))
- (internal (package-internal-symbols package))
- (symbols (symbol-listify symbols))
- (lock-asserted-p nil))
- (with-single-package-locked-error ()
- (dolist (sym symbols)
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (unless (or lock-asserted-p
- (and (eq s sym)
- (member s (package-shadowing-symbols package))))
- (assert-package-unlocked package "shadowing-importing symbol~P ~
+ (with-package-graph ()
+ (let* ((package (find-undeleted-package-or-lose package))
+ (internal (package-internal-symbols package))
+ (symbols (symbol-listify symbols))
+ (lock-asserted-p nil))
+ (with-single-package-locked-error ()
+ (dolist (sym symbols)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (unless (or lock-asserted-p
+ (and (eq s sym)
+ (member s (package-shadowing-symbols package))))
+ (assert-package-unlocked package "shadowing-importing symbol~P ~
~{~A~^, ~}" (length symbols) symbols)
- (setf lock-asserted-p t))
- (unless (and w (not (eq w :inherited)) (eq s sym))
- (when (or (eq w :internal) (eq w :external))
- ;; If it was shadowed, we don't want UNINTERN to flame out...
- (setf (package-%shadowing-symbols package)
- (remove s (the list (package-%shadowing-symbols package))))
- (unintern s package))
- (add-symbol internal sym))
- (pushnew sym (package-%shadowing-symbols package))))))
+ (setf lock-asserted-p t))
+ (unless (and w (not (eq w :inherited)) (eq s sym))
+ (when (or (eq w :internal) (eq w :external))
+ ;; If it was shadowed, we don't want UNINTERN to flame out...
+ (setf (package-%shadowing-symbols package)
+ (remove s (the list (package-%shadowing-symbols package))))
+ (unintern s package))
+ (add-symbol internal sym))
+ (pushnew sym (package-%shadowing-symbols package)))))))
t)
(defun shadow (symbols &optional (package (sane-package)))
#!+sb-doc
- "Make an internal symbol in PACKAGE with the same name as each of
- the specified SYMBOLS. If a symbol with the given name is already
- present in PACKAGE, then the existing symbol is placed in the
- shadowing symbols list if it is not already present."
- (let* ((package (find-undeleted-package-or-lose package))
- (internal (package-internal-symbols package))
- (symbols (string-listify symbols))
- (lock-asserted-p nil))
- (flet ((present-p (w)
- (and w (not (eq w :inherited)))))
- (with-single-package-locked-error ()
- (dolist (name symbols)
- (multiple-value-bind (s w) (find-symbol name package)
- (unless (or lock-asserted-p
- (and (present-p w)
- (member s (package-shadowing-symbols package))))
- (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
- (length symbols) symbols)
- (setf lock-asserted-p t))
- (unless (present-p w)
- (setq s (make-symbol name))
- (%set-symbol-package s package)
- (add-symbol internal s))
- (pushnew s (package-%shadowing-symbols package)))))))
+ "Make an internal symbol in PACKAGE with the same name as each of the
+specified 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."
+ (with-package-graph ()
+ (let* ((package (find-undeleted-package-or-lose package))
+ (internal (package-internal-symbols package))
+ (symbols (string-listify symbols))
+ (lock-asserted-p nil))
+ (flet ((present-p (w)
+ (and w (not (eq w :inherited)))))
+ (with-single-package-locked-error ()
+ (dolist (name symbols)
+ (multiple-value-bind (s w) (find-symbol name package)
+ (unless (or lock-asserted-p
+ (and (present-p w)
+ (member s (package-shadowing-symbols package))))
+ (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
+ (length symbols) symbols)
+ (setf lock-asserted-p t))
+ (unless (present-p w)
+ (setq s (make-symbol name))
+ (%set-symbol-package s package)
+ (add-symbol internal s))
+ (pushnew s (package-%shadowing-symbols package))))))))
t)
\f
;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
(defun use-package (packages-to-use &optional (package (sane-package)))
#!+sb-doc
- "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that
- the external symbols of the used packages are accessible as internal
- symbols in PACKAGE."
- (let ((packages (package-listify packages-to-use))
- (package (find-undeleted-package-or-lose package)))
-
- ;; Loop over each package, USE'ing one at a time...
- (with-single-package-locked-error ()
- (dolist (pkg packages)
- (unless (member pkg (package-%use-list package))
- (assert-package-unlocked package "using package~P ~{~A~^, ~}"
- (length packages) packages)
- (let ((shadowing-symbols (package-%shadowing-symbols package))
- (use-list (package-%use-list package)))
-
- ;; If the number of symbols already accessible is less
- ;; than the number to be inherited then it is faster to
- ;; run the test the other way. This is particularly
- ;; valuable in the case of a new package USEing
- ;; COMMON-LISP.
- (cond
- ((< (+ (package-internal-symbol-count package)
- (package-external-symbol-count package)
- (let ((res 0))
- (dolist (p use-list res)
- (incf res (package-external-symbol-count p)))))
- (package-external-symbol-count pkg))
- (do-symbols (sym package)
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) pkg)
- (when (and w
- (not (eq s sym))
- (not (member sym shadowing-symbols)))
- (name-conflict package 'use-package pkg sym s))))
- (dolist (p use-list)
- (do-external-symbols (sym p)
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) pkg)
- (when (and w
+ "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that the
+external symbols of the used packages are accessible as internal symbols in
+PACKAGE."
+ (with-package-graph ()
+ (let ((packages (package-listify packages-to-use))
+ (package (find-undeleted-package-or-lose package)))
+
+ ;; Loop over each package, USE'ing one at a time...
+ (with-single-package-locked-error ()
+ (dolist (pkg packages)
+ (unless (member pkg (package-%use-list package))
+ (assert-package-unlocked package "using package~P ~{~A~^, ~}"
+ (length packages) packages)
+ (let ((shadowing-symbols (package-%shadowing-symbols package))
+ (use-list (package-%use-list package)))
+
+ ;; If the number of symbols already accessible is less
+ ;; than the number to be inherited then it is faster to
+ ;; run the test the other way. This is particularly
+ ;; valuable in the case of a new package USEing
+ ;; COMMON-LISP.
+ (cond
+ ((< (+ (package-internal-symbol-count package)
+ (package-external-symbol-count package)
+ (let ((res 0))
+ (dolist (p use-list res)
+ (incf res (package-external-symbol-count p)))))
+ (package-external-symbol-count pkg))
+ (do-symbols (sym package)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) pkg)
+ (when (and w
(not (eq s sym))
- (not (member
- (find-symbol (symbol-name sym) package)
- shadowing-symbols)))
- (name-conflict package 'use-package pkg sym s))))))
- (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)))
- (name-conflict package 'use-package pkg sym s)))))))
-
- (push pkg (package-%use-list package))
- (push (package-external-symbols pkg) (cdr (package-tables package)))
- (push package (package-%used-by-list pkg))))))
+ (not (member sym shadowing-symbols)))
+ (name-conflict package 'use-package pkg sym s))))
+ (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)))
+ (name-conflict package 'use-package pkg sym s))))))
+ (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)))
+ (name-conflict package 'use-package pkg sym s)))))))
+
+ (push pkg (package-%use-list package))
+ (push (package-external-symbols pkg) (cdr (package-tables package)))
+ (push package (package-%used-by-list pkg)))))))
t)
(defun unuse-package (packages-to-unuse &optional (package (sane-package)))
#!+sb-doc
"Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
- (let ((package (find-undeleted-package-or-lose package))
- (packages (package-listify packages-to-unuse)))
- (with-single-package-locked-error ()
- (dolist (p packages)
- (when (member p (package-use-list package))
- (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
- (length packages) packages))
- (setf (package-%use-list package)
- (remove p (the list (package-%use-list package))))
- (setf (package-tables package)
- (delete (package-external-symbols p)
- (the list (package-tables package))))
- (setf (package-%used-by-list p)
- (remove package (the list (package-%used-by-list p))))))
- t))
+ (with-package-graph ()
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages (package-listify packages-to-unuse)))
+ (with-single-package-locked-error ()
+ (dolist (p packages)
+ (when (member p (package-use-list package))
+ (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
+ (length packages) packages))
+ (setf (package-%use-list package)
+ (remove p (the list (package-%use-list package))))
+ (setf (package-tables package)
+ (delete (package-external-symbols p)
+ (the list (package-tables package))))
+ (setf (package-%used-by-list p)
+ (remove package (the list (package-%used-by-list p))))))
+ t)))
(defun find-all-symbols (string-or-symbol)
#!+sb-doc
"Return a list of all symbols in the system having the specified name."
(let ((string (string string-or-symbol))
- (res ()))
- (maphash (lambda (k v)
- (declare (ignore k))
- (multiple-value-bind (s w) (find-symbol string v)
- (when w (pushnew s res))))
- *package-names*)
+ (res ()))
+ (with-package-names (names)
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (multiple-value-bind (s w) (find-symbol string v)
+ (when w (pushnew s res))))
+ names))
res))
\f
;;;; APROPOS and APROPOS-LIST
(write-string " (fbound)")))
(defun apropos-list (string-designator
- &optional
- package-designator
- external-only)
+ &optional
+ package-designator
+ external-only)
#!+sb-doc
"Like APROPOS, except that it returns a list of the symbols found instead
of describing them."
(if package-designator
(let ((package (find-undeleted-package-or-lose package-designator))
- (string (stringify-name string-designator "APROPOS search"))
- (result nil))
- (do-symbols (symbol package)
- (when (and (eq (symbol-package symbol) package)
- (or (not external-only)
- (eq (nth-value 1 (find-symbol (symbol-name symbol)
- package))
- :external))
- (search string (symbol-name symbol) :test #'char-equal))
- (push symbol result)))
- result)
+ (string (stringify-string-designator string-designator))
+ (result nil))
+ (do-symbols (symbol package)
+ (when (and (eq (symbol-package symbol) package)
+ (or (not external-only)
+ (eq (nth-value 1 (find-symbol (symbol-name symbol)
+ package))
+ :external))
+ (search string (symbol-name symbol) :test #'char-equal))
+ (push symbol result)))
+ (sort result #'string-lessp))
(mapcan (lambda (package)
- (apropos-list string-designator package external-only))
- (list-all-packages))))
+ (apropos-list string-designator package external-only))
+ (sort (list-all-packages) #'string-lessp :key #'package-name))))
(defun apropos (string-designator &optional package external-only)
#!+sb-doc
(/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages")
(dolist (spec *!initial-symbols*)
(let* ((pkg (apply #'make-package (first spec)))
- (internal (package-internal-symbols pkg))
- (external (package-external-symbols pkg)))
+ (internal (package-internal-symbols pkg))
+ (external (package-external-symbols pkg)))
(/show0 "back from MAKE-PACKAGE, PACKAGE-NAME=..")
(/primitive-print (package-name pkg))
;; Put internal symbols in the internal hashtable and set package.
(dolist (symbol (second spec))
- (add-symbol internal symbol)
- (%set-symbol-package symbol pkg))
+ (add-symbol internal symbol)
+ (%set-symbol-package symbol pkg))
;; External symbols same, only go in external table.
(dolist (symbol (third spec))
- (add-symbol external symbol)
- (%set-symbol-package symbol pkg))
+ (add-symbol external symbol)
+ (%set-symbol-package symbol pkg))
;; Don't set package for imported symbols.
(dolist (symbol (fourth spec))
- (add-symbol internal symbol))
+ (add-symbol internal symbol))
(dolist (symbol (fifth spec))
- (add-symbol external symbol))
+ (add-symbol external symbol))
;; Put shadowing symbols in the shadowing symbols list.
(setf (package-%shadowing-symbols pkg) (sixth spec))
(setq *keyword-package* (find-package "KEYWORD"))
(/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
- (makunbound '*!initial-symbols*) ; (so that it gets GCed)
+ (%makunbound '*!initial-symbols*) ; (so that it gets GCed)
;; Make some other packages that should be around in the cold load.
;; The COMMON-LISP-USER package is required by the ANSI standard,
;; ..but instead making our own from scratch here.
(/show0 "about to MAKE-PACKAGE COMMON-LISP-USER")
(make-package "COMMON-LISP-USER"
- :nicknames '("CL-USER")
- :use '("COMMON-LISP"
- ;; ANSI encourages us to put extension packages
- ;; in the USE list of COMMON-LISP-USER.
- "SB!ALIEN" "SB!ALIEN" "SB!DEBUG"
- "SB!EXT" "SB!GRAY" "SB!PROFILE"))
+ :nicknames '("CL-USER")
+ :use '("COMMON-LISP"
+ ;; ANSI encourages us to put extension packages
+ ;; in the USE list of COMMON-LISP-USER.
+ "SB!ALIEN" "SB!ALIEN" "SB!DEBUG"
+ "SB!EXT" "SB!GRAY" "SB!PROFILE"))
;; Now do the *!DEFERRED-USE-PACKAGES*.
(/show0 "about to do *!DEFERRED-USE-PACKAGES*")
projects / sbcl.git / blobdiff