X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=673d17039912c2a9c59f29f70d603862e29457e3;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=88b3cbf69de71c6e8c75ac731688988ae48be46b;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 88b3cbf..673d170 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -34,10 +34,10 @@ (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 density we allow in a package hashtable (defconstant package-rehash-threshold 0.75) @@ -48,7 +48,7 @@ ;;; useful when changing the size, since there are many pointers to ;;; the hashtable. (defun make-or-remake-package-hashtable (size - &optional + &optional res) (flet ((actual-package-hashtable-size (size) (loop for n of-type fixnum @@ -74,33 +74,33 @@ #!+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))) @@ -108,28 +108,28 @@ of. Signals an error if PACKAGE is not a valid package designator." 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))))) @@ -140,15 +140,15 @@ error if any of PACKAGES is not a valid package designator." (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) @@ -187,7 +187,7 @@ error if any of PACKAGES is not a valid package designator." ;; 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*) @@ -214,15 +214,15 @@ error if any of PACKAGES is not a valid package designator." ;;; ;;; 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 @@ -236,23 +236,23 @@ error if any of PACKAGES is not a valid package designator." (declare (ignore format)) #!+sb-package-locks (let* ((symbol (etypecase name - (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))) + (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) @@ -261,16 +261,16 @@ error if any of PACKAGES is not a valid package designator." (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) @@ -278,8 +278,8 @@ error if any of PACKAGES is not a valid package designator." (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))))) @@ -289,7 +289,7 @@ error if any of PACKAGES is not a valid package designator." (defun package-external-symbol-count (package) (%package-hashtable-symbol-count (package-external-symbols package))) -(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 @@ -319,34 +319,34 @@ error if any of PACKAGES is not a valid package designator." (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. @@ -372,94 +372,94 @@ error if any of PACKAGES is not a valid package designator." ;;; 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) (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)))))))) + (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))))))) + (make-or-remake-package-hashtable (* (package-hashtable-size table) + 2) + table) + (add-symbol table symbol) + (dotimes (i len) + (declare (fixnum i)) + (when (> (the fixnum (aref hash i)) 1) + (add-symbol table (svref vec i))))) + (t + (do ((i (rem sxhash len) (rem (+ i h2) len))) + ((< (the fixnum (aref hash i)) 2) + (if (zerop (the fixnum (aref hash i))) + (decf (package-hashtable-free table)) + (decf (package-hashtable-deleted table))) + (setf (svref vec i) symbol) + (setf (aref hash i) + (entry-hash (length (symbol-name symbol)) + sxhash))) + (declare (fixnum i))))))) ;;; Find where the symbol named STRING is stored in TABLE. INDEX-VAR ;;; is bound to the index, or NIL if it is not present. SYMBOL-VAR ;;; is bound to the symbol. LENGTH and HASH are the length and sxhash ;;; of STRING. ENTRY-HASH is the entry-hash of the string and length. (defmacro with-symbol ((index-var symbol-var table string length sxhash - entry-hash) - &body forms) + 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 index ,sxhash) + (the index (- ,len 2))))))) (declare (type index ,len ,h2)) (prog ((,index-var (rem (the index ,sxhash) ,len)) - ,symbol-var ,ehash) - (declare (type (or index null) ,index-var)) - LOOP - (setq ,ehash (aref ,hash ,index-var)) - (cond ((eql ,ehash ,entry-hash) - (setq ,symbol-var (svref ,vec ,index-var)) - (let* ((,name (symbol-name ,symbol-var)) - (,name-len (length ,name))) - (declare (type index ,name-len)) - (when (and (= ,name-len ,length) - (string= ,string ,name - :end1 ,length - :end2 ,name-len)) - (go DOIT)))) - ((zerop ,ehash) - (setq ,index-var nil) - (go DOIT))) - (setq ,index-var (+ ,index-var ,h2)) - (when (>= ,index-var ,len) - (setq ,index-var (- ,index-var ,len))) - (go LOOP) - DOIT - (return (progn ,@forms)))))) + ,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))) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (index symbol table string length hash ehash) (setf (aref (package-hashtable-hash table) index) 1) @@ -473,32 +473,32 @@ error if any of PACKAGES is not a valid package designator." (declare (type list nicknames)) (dolist (n nicknames) (let* ((n (package-namify n)) - (found (gethash n *package-names*))) + (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) + (setf (gethash n *package-names*) package) + (push n (package-%nicknames package))) + ((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 + "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 @@ -511,20 +511,20 @@ error if any of PACKAGES is not a valid package designator." (when (find-package name) ;; ANSI specifies that this error is correctable. (cerror "Leave existing package alone." - "A package named ~S already exists" name)) + "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)))) + (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)) + (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 @@ -549,28 +549,28 @@ error if any of PACKAGES is not a valid package designator." #!+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))) + (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))) + :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)) + (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*)) + (remhash n *package-names*)) (setf (package-%name package) name - (gethash name *package-names*) package - (package-%nicknames package) ()) + (gethash name *package-names*) package + (package-%nicknames package) ()) (enter-new-nicknames package nicknames)) package)) @@ -579,10 +579,10 @@ error if any of PACKAGES is not a valid package designator." "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)))) + package-designator + (find-package package-designator)))) (cond ((not package) - ;; This continuable error is required by ANSI. + ;; This continuable error is required by ANSI. (cerror "Return ~S." (make-condition @@ -591,14 +591,14 @@ error if any of PACKAGES is not a valid 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. + ((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 @@ -609,39 +609,39 @@ error if any of PACKAGES is not a valid package designator." :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))))) + (dolist (p use-list) + (unuse-package package p)))) + (dolist (used (package-use-list package)) + (unuse-package used package)) + (do-symbols (sym package) + (unintern sym package)) + (remhash (package-name package) *package-names*) + (dolist (nick (package-nicknames package)) + (remhash nick *package-names*)) + (setf (package-%name package) nil + ;; Setting PACKAGE-%NAME to NIL is required in order to + ;; make PACKAGE-NAME return NIL for a deleted package as + ;; ANSI requires. Setting the other slots to NIL + ;; and blowing away the PACKAGE-HASHTABLES is just done + ;; for tidiness and to help the GC. + (package-%nicknames package) nil + (package-%use-list package) nil + (package-tables package) nil + (package-%shadowing-symbols package) nil + (package-internal-symbols package) + (make-or-remake-package-hashtable 0) + (package-external-symbols package) + (make-or-remake-package-hashtable 0)) + t))))) (defun list-all-packages () #!+sb-doc "Return a list of all existing packages." (let ((res ())) (maphash (lambda (k v) - (declare (ignore k)) - (pushnew v res)) - *package-names*) + (declare (ignore k)) + (pushnew v res)) + *package-names*) res)) (defun intern (name &optional (package (sane-package))) @@ -651,13 +651,13 @@ error if any of PACKAGES is not a valid package designator." ;; 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 @@ -670,8 +670,8 @@ error if any of PACKAGES is not a valid package designator." (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. @@ -679,46 +679,46 @@ error if any of PACKAGES is not a valid package designator." (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 ((symbol-name (subseq name 0 length))) + (with-single-package-locked-error + (:package package "interning ~A" symbol-name) + (let ((symbol (make-symbol symbol-name))) + (%set-symbol-package symbol package) + (cond ((eq package *keyword-package*) + (add-symbol (package-external-symbols package) symbol) + (%set-symbol-value symbol symbol)) + (t + (add-symbol (package-internal-symbols package) symbol))) + (values symbol nil)))))))) ;;; Check internal and external symbols, then scan down the list ;;; of hashtables for inherited symbols. When an inherited symbol ;;; is found pull that table to the beginning of the list. (defun find-symbol* (string length package) (declare (simple-string string) - (type index length)) + (type index length)) (let* ((hash (%sxhash-simple-substring string length)) - (ehash (entry-hash length hash))) + (ehash (entry-hash length hash))) (declare (type index 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 + (unless (eq prev head) + (shiftf (cdr prev) (cdr table) (cdr head) table)) + (return-from find-symbol* (values symbol :inherited)))))))) ;;; Similar to FIND-SYMBOL, but only looks for an external symbol. ;;; This is used for fast name-conflict checking in this file and symbol @@ -726,11 +726,11 @@ error if any of PACKAGES is not a valid package designator." (defun find-external-symbol (string package) (declare (simple-string string)) (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) + string length hash ehash) (values symbol found)))) (define-condition name-conflict (reference-condition package-error) @@ -874,53 +874,53 @@ error if any of PACKAGES is not a valid package designator." 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))) + (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)) - + (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) + (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))) + (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)))))) + (declare (ignore s)) + (cond ((or (eq w :internal) (eq w :external)) + (nuke-symbol (if (eq w :internal) + (package-internal-symbols package) + (package-external-symbols package)) + name) + (if (eq (symbol-package symbol) package) + (%set-symbol-package symbol nil)) + t) + (t nil)))))) ;;; Take a symbol-or-list-of-symbols and return a list, checking types. (defun symbol-listify (thing) (cond ((listp thing) - (dolist (s thing) - (unless (symbolp s) (error "~S is not a symbol." s))) - thing) - ((symbolp thing) (list thing)) - (t - (error "~S is neither a symbol nor a list of symbols." thing)))) + (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 @@ -929,59 +929,59 @@ error if any of PACKAGES is not a valid package designator." (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)))))))))) (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 ())) + (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-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)) + (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 + (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)))) + (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 + (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 + (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 @@ -991,15 +991,15 @@ error if any of PACKAGES is not a valid package designator." "~@" :format-arguments (list (package-%name package) missing)) 'import (package-%name package)) - (import missing package)) - (import imports 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)))) + (external (package-external-symbols package))) + (dolist (sym syms) + (nuke-symbol internal (symbol-name sym)) + (add-symbol external sym)))) t)) ;;; Check that all symbols are accessible, then move from external to internal. @@ -1007,24 +1007,24 @@ error if any of PACKAGES is not a valid package designator." #!+sb-doc "Makes SYMBOLS no longer exported from PACKAGE." (let ((package (find-undeleted-package-or-lose package)) - (syms ())) + (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))))) + (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)) + (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))))) + (external (package-external-symbols package))) + (dolist (sym syms) + (add-symbol internal sym) + (nuke-symbol external (symbol-name sym))))) t)) ;;; Check for name conflict caused by the import and let the user @@ -1035,9 +1035,9 @@ error if any of PACKAGES is not a valid package designator." 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 ())) + (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) @@ -1051,16 +1051,16 @@ error if any of PACKAGES is not a valid package designator." (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))) + (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))) + (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)) + (%set-symbol-package sym package)) t))) ;;; If a conflicting symbol is present, unintern it, otherwise just @@ -1070,26 +1070,26 @@ error if any of PACKAGES is not a valid package designator." "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)) + (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 ~ + (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))) @@ -1099,25 +1099,25 @@ error if any of PACKAGES is not a valid package designator." 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)) + (internal (package-internal-symbols package)) + (symbols (string-listify symbols)) + (lock-asserted-p nil)) (flet ((present-p (w) - (and w (not (eq w :inherited))))) + (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))))))) + (dolist (name symbols) + (multiple-value-bind (s w) (find-symbol name package) + (unless (or lock-asserted-p + (and (present-p w) + (member s (package-shadowing-symbols package)))) + (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}" + (length symbols) symbols) + (setf lock-asserted-p t)) + (unless (present-p w) + (setq s (make-symbol name)) + (%set-symbol-package s package) + (add-symbol internal s)) + (pushnew s (package-%shadowing-symbols package))))))) t) ;;; Do stuff to use a package, with all kinds of fun name-conflict checking. @@ -1127,89 +1127,89 @@ error if any of PACKAGES is not a valid package designator." 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))) + (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 + (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))) + (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 + (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 + (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 + (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))) + (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)))))) + + (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))) + (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)))))) + (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 ())) + (res ())) (maphash (lambda (k v) - (declare (ignore k)) - (multiple-value-bind (s w) (find-symbol string v) - (when w (pushnew s res)))) - *package-names*) + (declare (ignore k)) + (multiple-value-bind (s w) (find-symbol string v) + (when w (pushnew s res)))) + *package-names*) res)) ;;;; APROPOS and APROPOS-LIST @@ -1223,28 +1223,28 @@ error if any of PACKAGES is not a valid package designator." (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-name string-designator "APROPOS search")) + (result nil)) + (do-symbols (symbol package) + (when (and (eq (symbol-package symbol) package) + (or (not external-only) + (eq (nth-value 1 (find-symbol (symbol-name symbol) + package)) + :external)) + (search string (symbol-name symbol) :test #'char-equal)) + (push symbol result))) + result) (mapcan (lambda (package) - (apropos-list string-designator package external-only)) - (list-all-packages)))) + (apropos-list string-designator package external-only)) + (list-all-packages)))) (defun apropos (string-designator &optional package external-only) #!+sb-doc @@ -1276,26 +1276,26 @@ error if any of PACKAGES is not a valid package designator." (/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)) @@ -1322,12 +1322,12 @@ error if any of PACKAGES is not a valid package designator." ;; ..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*")