- ":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))))
"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)
"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)
"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)
"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)
"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)
"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)
"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)))
"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)))
"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)))
"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)))
"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))
"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))
(setf (package-%implementation-packages package)
(union (package-%implementation-packages package)
(mapcar #'find-undeleted-package-or-lose packages-to-add)))))
(setf (package-%implementation-packages package)
(union (package-%implementation-packages package)
(mapcar #'find-undeleted-package-or-lose packages-to-add)))))
"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))
"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))
(dolist (p ',packages)
(when (package-locked-p p)
(push p ,unlocked-packages)
(unlock-package p)))
,@forms)
(dolist (p ,unlocked-packages)
(dolist (p ',packages)
(when (package-locked-p p)
(push p ,unlocked-packages)
(unlock-package p)))
,@forms)
(dolist (p ,unlocked-packages)
;; comparison to *package*, since during cold init this gets
;; called before *package* is bound -- but no package should
;; be locked at that point.
;; comparison to *package*, since during cold init this gets
;; called before *package* is bound -- but no package should
;; be locked at that point.
- (package-lock-violation package
- :format-control format-control
- :format-arguments format-arguments))
+ (package-lock-violation package
+ :format-control format-control
+ :format-arguments format-arguments))
- (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)))
- (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)
;;; 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)
(def package-nicknames package-%nicknames)
(def package-use-list package-%use-list)
(def package-used-by-list package-%used-by-list)
(def package-nicknames package-%nicknames)
(def package-use-list package-%use-list)
(def package-used-by-list package-%used-by-list)
#!+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
#!+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
(define-condition bootstrap-package-not-found (condition)
((name :initarg :name :reader bootstrap-package-name)))
(defun debootstrap-package (&optional condition)
(define-condition bootstrap-package-not-found (condition)
((name :initarg :name :reader bootstrap-package-name)))
(defun debootstrap-package (&optional condition)
- (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
(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
- (+ (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))
;;; 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))))))))
- (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
;;; 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
- (,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))
(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))
;;; Delete the entry for STRING in TABLE. The entry must exist.
(defun nuke-symbol (table string)
(declare (simple-string string))
(let* ((length (length string))
(declare (type index length hash))
(with-symbol (index symbol table string length hash ehash)
(setf (aref (package-hashtable-hash table) index) 1)
(declare (type index length hash))
(with-symbol (index symbol table string length hash ehash)
(setf (aref (package-hashtable-hash table) index) 1)
- (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)
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 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
(when (find-package name)
;; ANSI specifies that this error is correctable.
(cerror "Leave existing package alone."
(when (find-package name)
;; ANSI specifies that this error is correctable.
(cerror "Leave existing package alone."
- (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))))
- (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 (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))
- ((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.
- (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)))))
;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
;;; then create it, special-casing the keyword package.
;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
;;; then create it, special-casing the keyword package.
- (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)
;;; 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)
- (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))))))))
(defun find-external-symbol (string package)
(declare (simple-string string))
(let* ((length (length string))
(defun find-external-symbol (string package)
(declare (simple-string string))
(let* ((length (length string))
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))
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))
(declare (list shadowing-symbols))
(with-single-package-locked-error ()
(when (find-symbol name package)
(declare (list shadowing-symbols))
(with-single-package-locked-error ()
(when (find-symbol name package)
;; If a name conflict is revealed, give us a chance to
;; shadowing-import one of the accessible symbols.
(when (member symbol shadowing-symbols)
;; 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)
- (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))))))
- (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))))
;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
;;; down the package it is inherited from and uninterns it there. Used
;;; 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)
(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))
\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))
;; Punt any symbols that are already external.
(dolist (sym (symbol-listify symbols))
(multiple-value-bind (s w)
;; Punt any symbols that are already external.
(dolist (sym (symbol-listify symbols))
(multiple-value-bind (s w)
"~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
:format-arguments (list (package-%name package) missing))
'import (package-%name package))
"~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
:format-arguments (list (package-%name package) missing))
'import (package-%name package))
;; And now, three pages later, we export the suckers.
(let ((internal (package-internal-symbols 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))))
- (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)))))
- (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)))))
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))
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))
- (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)))
"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))
"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))
- (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 ~
- (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))))))
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))
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))
- (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)))))))
- (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
- (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
- (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
-
- (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))
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))
- (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))
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))
- (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)
(/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages")
(dolist (spec *!initial-symbols*)
(let* ((pkg (apply #'make-package (first spec)))
(/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages")
(dolist (spec *!initial-symbols*)
(let* ((pkg (apply #'make-package (first spec)))
(/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))
(/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))
;; ..but instead making our own from scratch here.
(/show0 "about to MAKE-PACKAGE COMMON-LISP-USER")
(make-package "COMMON-LISP-USER"
;; ..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"))