;;;; symbol. A name conflict is said to occur when there would be more
;;;; than one candidate symbol. Any time a name conflict is about to
;;;; occur, a correctable error is signaled.
+;;;;
+;;;; FIXME: The code contains a lot of type declarations. Are they
+;;;; all really necessary?
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;; the hashtable.
(defun make-or-remake-package-hashtable (size
&optional
- (res (%make-package-hashtable)))
- (do ((n (logior (truncate size package-rehash-threshold) 1)
- (+ n 2)))
- ((positive-primep n)
- (setf (package-hashtable-table res)
- (make-array n))
- (setf (package-hashtable-hash res)
- (make-array n
- :element-type '(unsigned-byte 8)
- :initial-element 0))
- (let ((size (truncate (* n package-rehash-threshold))))
- (setf (package-hashtable-size res) size)
- (setf (package-hashtable-free res) size))
- (setf (package-hashtable-deleted res) 0)
- res)
- (declare (type fixnum n))))
+ res)
+ (flet ((actual-package-hashtable-size (size)
+ (loop for n of-type fixnum
+ from (logior (truncate 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)))
+ (table (make-array n))
+ (hash (make-array n
+ :element-type '(unsigned-byte 8)
+ :initial-element 0)))
+ (if res
+ (setf (package-hashtable-table res) table
+ (package-hashtable-hash res) hash
+ (package-hashtable-size res) size
+ (package-hashtable-free res) size
+ (package-hashtable-deleted res) 0)
+ (setf res (%make-package-hashtable table hash size)))
+ res)))
+\f
+;;;; package locking operations, built conditionally on :sb-package-locks
+
+#!+sb-package-locks
+(progn
+(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
+ "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
+ "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
+ "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
+ "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)))
+ (loop for x in (list-all-packages)
+ when (member package (package-%implementation-packages x))
+ collect x)))
+
+(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)))
+ (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
+ "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)))
+ (setf (package-%implementation-packages package)
+ (nset-difference
+ (package-%implementation-packages package)
+ (mapcar #'find-undeleted-package-or-lose packages-to-remove)))))
+
+(defmacro with-unlocked-packages ((&rest packages) &body forms)
+ #!+sb-doc
+ "Unlocks PACKAGES for the dynamic scope of the body. Signals an
+error if any of PACKAGES is not a valid package designator."
+ (with-unique-names (unlocked-packages)
+ `(let (,unlocked-packages)
+ (unwind-protect
+ (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)))))))
+
+(defun package-lock-violation (package &key (symbol nil symbol-p)
+ format-control format-arguments)
+ (let* ((restart :continue)
+ (cl-violation-p (eq package *cl-package*))
+ (error-arguments
+ (append (list (if symbol-p
+ 'symbol-package-locked-error
+ 'package-locked-error)
+ :package package
+ :format-control format-control
+ :format-arguments format-arguments)
+ (when symbol-p (list :symbol symbol))
+ (list :references
+ (append '((:sbcl :node "Package Locks"))
+ (when cl-violation-p
+ '((:ansi-cl :section (11 1 2 1 2)))))))))
+ (restart-case
+ (apply #'cerror "Ignore the package lock." error-arguments)
+ (:ignore-all ()
+ :report "Ignore all package locks in the context of this operation."
+ (setf restart :ignore-all))
+ (:unlock-package ()
+ :report "Unlock the package."
+ (setf restart :unlock-package)))
+ (ecase restart
+ (:continue
+ (pushnew package *ignored-package-locks*))
+ (:ignore-all
+ (setf *ignored-package-locks* t))
+ (:unlock-package
+ (unlock-package package)))))
+
+(defun package-lock-violation-p (package &optional (symbol nil symbolp))
+ ;; KLUDGE: (package-lock package) needs to be before
+ ;; 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
+ (package-lock package)
+ ;; In package or implementation package
+ (not (or (eq package *package*)
+ (member *package* (package-%implementation-packages package))))
+ ;; Runtime disabling
+ (not (eq t *ignored-package-locks*))
+ (or (eq :invalid *ignored-package-locks*)
+ (not (member package *ignored-package-locks*)))
+ ;; declarations for symbols
+ (not (and symbolp (member symbol (disabled-package-locks))))))
+
+(defun disabled-package-locks ()
+ (if (boundp 'sb!c::*lexenv*)
+ (sb!c::lexenv-disabled-package-locks sb!c::*lexenv*)
+ sb!c::*disabled-package-locks*))
+
+) ; progn
+
+;;;; more package-locking these are NOPs unless :sb-package-locks is
+;;;; in target features. Cross-compiler NOPs for these are in cross-misc.
+
+;;; The right way to establish a package lock context is
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR, defined in early-package.lisp
+;;;
+;;; 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
+ (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)
+
+;;; Must be used inside the dynamic contour established by
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR.
+;;;
+;;; FIXME: Maybe we should establish such contours for he toplevel
+;;; and others, so that %set-fdefinition and others could just use
+;;; this.
+(defun assert-symbol-home-package-unlocked (name format)
+ #!-sb-package-locks
+ (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)))
+ (when (package-lock-violation-p package symbol)
+ (package-lock-violation package
+ :symbol symbol
+ :format-control format
+ :format-arguments (list name))))
+ name)
+
\f
;;;; miscellaneous PACKAGE operations
(defun %package-hashtable-symbol-count (table)
(let ((size (the fixnum
- (- (the fixnum (package-hashtable-size table))
- (the fixnum
- (package-hashtable-deleted table))))))
- (declare (fixnum size))
+ (- (package-hashtable-size table)
+ (package-hashtable-deleted table)))))
(the fixnum
- (- size
- (the fixnum
- (package-hashtable-free table))))))
+ (- size (package-hashtable-free table)))))
(defun package-internal-symbol-count (package)
(%package-hashtable-symbol-count (package-internal-symbols package)))
(!cold-init-forms
(setf *!deferred-use-packages* nil))
-;;; FIXME: I rewrote this. Test it and the stuff that calls it.
+(define-condition bootstrap-package-not-found (condition)
+ ((name :initarg :name :reader bootstrap-package-name)))
+(defun debootstrap-package (&optional condition)
+ (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))
- (values (gethash string *package-names*))))
- (declare (inline find-package-from-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)))
(sxhash (%sxhash-simple-string (symbol-name symbol)))
(h2 (the fixnum (1+ (the fixnum (rem sxhash
(the fixnum (- len 2))))))))
- (declare (simple-vector vec)
- (type (simple-array (unsigned-byte 8)) hash)
- (fixnum len sxhash h2))
+ (declare (fixnum len sxhash h2))
(cond ((zerop (the fixnum (package-hashtable-free table)))
(make-or-remake-package-hashtable (* (package-hashtable-size table)
2)
(do ((i (rem sxhash len) (rem (+ i h2) len)))
((< (the fixnum (aref hash i)) 2)
(if (zerop (the fixnum (aref hash i)))
- (decf (the fixnum (package-hashtable-free table)))
- (decf (the fixnum (package-hashtable-deleted table))))
+ (decf (package-hashtable-free table))
+ (decf (package-hashtable-deleted table)))
(setf (svref vec i) symbol)
(setf (aref hash i)
- (entry-hash (length (the simple-string
- (symbol-name symbol)))
+ (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.
+;;; 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)
(,len (length ,vec))
(,h2 (1+ (the index (rem (the index ,sxhash)
(the index (- ,len 2)))))))
- (declare (type (simple-array (unsigned-byte 8) (*)) ,hash)
- (simple-vector ,vec)
- (type index ,len ,h2))
+ (declare (type index ,len ,h2))
(prog ((,index-var (rem (the index ,sxhash) ,len))
,symbol-var ,ehash)
(declare (type (or index null) ,index-var))
(setq ,symbol-var (svref ,vec ,index-var))
(let* ((,name (symbol-name ,symbol-var))
(,name-len (length ,name)))
- (declare (simple-string ,name)
- (type index ,name-len))
+ (declare (type index ,name-len))
(when (and (= ,name-len ,length)
(string= ,string ,name
:end1 ,length
(push n (package-%nicknames package)))
((eq found package))
((string= (the string (package-%name found)) n)
- ;; FIXME: This and the next error needn't have restarts.
- (with-simple-restart (continue "Ignore this nickname.")
- (error '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)))))
+ (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
- (with-simple-restart (continue "Redefine this nickname.")
- (error 'simple-package-error
- :package package
- :format-control "~S is already a nickname for ~S."
- :format-arguments (list n (package-%name found))))
- (setf (gethash n *package-names*) package)
- (push n (package-%nicknames package)))))))
+ (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))))))))
(defun make-package (name &key
(use '#.*default-package-use-list*)
#!+sb-doc
"Changes the name and nicknames for a package."
(let* ((package (find-undeleted-package-or-lose package))
- (name (string name))
- (found (find-package name)))
+ (name (package-namify name))
+ (found (find-package name))
+ (nicks (mapcar #'string nicknames)))
(unless (or (not found) (eq found package))
- (error "A package named ~S already exists." name))
- (remhash (package-%name package) *package-names*)
- (dolist (n (package-%nicknames package))
- (remhash n *package-names*))
- (setf (package-%name package) name)
- (setf (gethash name *package-names*) package)
- (setf (package-%nicknames package) ())
- (enter-new-nicknames package nicknames)
+ (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))
package))
-(defun delete-package (package-or-name)
+(defun delete-package (package-designator)
#!+sb-doc
- "Delete the package-or-name from the package system data structures."
- (let ((package (if (packagep package-or-name)
- package-or-name
- (find-package package-or-name))))
+ "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.
- (with-simple-restart (continue "Return NIL")
- (error 'simple-package-error
- :package package-or-name
- :format-control "There is no package named ~S."
- :format-arguments (list package-or-name))))
+ (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
- (let ((use-list (package-used-by-list package)))
- (when use-list
- ;; This continuable error is specified by ANSI.
- (with-simple-restart
- (continue "Remove dependency in other packages.")
- (error 'simple-package-error
- :package package
- :format-control
- "Package ~S is used by package(s):~% ~S"
- :format-arguments
- (list (package-name package)
- (mapcar #'package-name use-list))))
- (dolist (p use-list)
- (unuse-package package p))))
- (dolist (used (package-use-list package))
- (unuse-package used package))
- (do-symbols (sym package)
- (unintern sym package))
- (remhash (package-name package) *package-names*)
- (dolist (nick (package-nicknames package))
- (remhash nick *package-names*))
- (setf (package-%name package) nil
- ;; 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))))
+ (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)))))
(defun list-all-packages ()
#!+sb-doc
\f
(defun intern (name &optional (package (sane-package)))
#!+sb-doc
- "Return a symbol having the specified name, creating it if necessary."
+ "Return a symbol in PACKAGE having the specified NAME, creating it
+ if necessary."
;; 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))))
+ name
+ (coerce name 'simple-string)))
+ (package (find-undeleted-package-or-lose package)))
(declare (simple-string name))
- (intern* name
- (length name)
- (find-undeleted-package-or-lose package))))
+ (intern* name
+ (length name)
+ package)))
(defun find-symbol (name &optional (package (sane-package)))
#!+sb-doc
- "Return the symbol named String in Package. If such a symbol is found
- then the second value is :internal, :external or :inherited to indicate
+ "Return the symbol named STRING in PACKAGE. If such a symbol is found
+ then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate
how the symbol is accessible. If no symbol is found then both values
are NIL."
;; We just simple-stringify the name and call FIND-SYMBOL*, where the
(defun intern* (name length package)
(declare (simple-string name))
(multiple-value-bind (symbol where) (find-symbol* name length package)
- (if where
- (values symbol where)
- (let ((symbol (make-symbol (subseq name 0 length))))
- (%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)))))
+ (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))))))))
;;; Check internal and external symbols, then scan down the list
;;; of hashtables for inherited symbols. When an inherited symbol
(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.
+;;; Similar to FIND-SYMBOL, but only looks for an external symbol.
;;; This is used for fast name-conflict checking in this file and symbol
;;; printing in the printer.
(defun find-external-symbol (string package)
string length hash ehash)
(values symbol found))))
\f
+(define-condition name-conflict (reference-condition package-error)
+ ((function :initarg :function :reader name-conflict-function)
+ (datum :initarg :datum :reader name-conflict-datum)
+ (symbols :initarg :symbols :reader name-conflict-symbols))
+ (:default-initargs :references (list '(:ansi-cl :section (11 1 1 2 5))))
+ (:report
+ (lambda (c s)
+ (format s "~@<~S ~S causes name-conflicts in ~S between the ~
+ following symbols:~2I~@:_~{~S~^, ~}~:@>"
+ (name-conflict-function c)
+ (name-conflict-datum c)
+ (package-error-package c)
+ (name-conflict-symbols c)))))
+
+(defun name-conflict (package function datum &rest symbols)
+ (restart-case
+ (error 'name-conflict :package package :symbols symbols
+ :function function :datum datum)
+ (resolve-conflict (s)
+ :report "Resolve conflict."
+ :interactive
+ (lambda ()
+ (let* ((len (length symbols))
+ (nlen (length (write-to-string len :base 10))))
+ (format *query-io* "~&~@<Select a symbol to be made accessible in ~
+ package ~A:~2I~@:_~{~{~V,' D. ~S~}~@:_~}~@:>"
+ (package-name package)
+ (loop for s in symbols
+ for i upfrom 1
+ collect (list nlen i s)))
+ (loop
+ (format *query-io* "~&Enter an integer (between 1 and ~D): " len)
+ (finish-output *query-io*)
+ (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))))))
+
;;; 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
+ "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) (simple-string name))
-
- ;; If a name conflict is revealed, give use a chance to shadowing-import
- ;; one of the accessible symbols.
- (when (member symbol shadowing-symbols)
- (let ((cset ()))
- (dolist (p (package-%use-list package))
- (multiple-value-bind (s w) (find-external-symbol name p)
- (when w (pushnew s cset))))
- (when (cdr cset)
- (loop
- (cerror
- "Prompt for a symbol to SHADOWING-IMPORT."
- "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
- symbol cset)
- (write-string "Symbol to shadowing-import: " *query-io*)
- (let ((sym (read *query-io*)))
- (cond
- ((not (symbolp sym))
- (format *query-io* "~S is not a symbol."))
- ((not (member sym cset))
- (format *query-io* "~S is not one of the conflicting symbols."))
- (t
- (shadowing-import sym package)
- (return-from unintern t)))))))
- (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 (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)
(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))))
+
;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
;;; down the package it is inherited from and uninterns it there. Used
;;; for name-conflict resolution. Shadowing symbols are not uninterned
\f
(defun export (symbols &optional (package (sane-package)))
#!+sb-doc
- "Exports Symbols from Package, checking that no name conflicts result."
+ "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.
(declare (ignore s))
(unless (or w (member sym syms))
(push sym syms))))
- ;; Find symbols and packages with conflicts.
- (let ((used-by (package-%used-by-list package))
- (cpackages ())
- (cset ()))
- (dolist (sym syms)
- (let ((name (symbol-name sym)))
- (dolist (p used-by)
- (multiple-value-bind (s w) (find-symbol name p)
- (when (and w (not (eq s sym))
- (not (member s (package-%shadowing-symbols p))))
- (pushnew sym cset)
- (pushnew p cpackages))))))
- (when cset
- (restart-case
- (error
- 'simple-package-error
- :package package
- :format-control
- "Exporting these symbols from the ~A package:~%~S~%~
- results in name conflicts with these packages:~%~{~A ~}"
- :format-arguments
- (list (package-%name package) cset
- (mapcar #'package-%name cpackages)))
- (unintern-conflicting-symbols ()
- :report "Unintern conflicting symbols."
- (dolist (p cpackages)
- (dolist (sym cset)
- (moby-unintern sym p))))
- (skip-exporting-these-symbols ()
- :report "Skip exporting conflicting symbols."
- (setq syms (nset-difference syms cset))))))
-
- ;; Check that all symbols are accessible. If not, ask to import them.
- (let ((missing ())
- (imports ()))
- (dolist (sym syms)
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (cond ((not (and w (eq s sym)))
- (push sym missing))
- ((eq w :inherited)
- (push sym imports)))))
- (when missing
- (with-simple-restart
- (continue "Import these symbols into the ~A package."
- (package-%name package))
- (error 'simple-package-error
- :package package
- :format-control
- "These symbols are not accessible in the ~A package:~%~S"
- :format-arguments
- (list (package-%name package) missing)))
- (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-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))
\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."
+ "Makes SYMBOLS no longer exported from PACKAGE."
(let ((package (find-undeleted-package-or-lose package))
(syms ()))
(dolist (sym (symbol-listify symbols))
:format-control "~S is not accessible in the ~A package."
:format-arguments (list sym (package-%name package))))
((eq w :external) (pushnew sym syms)))))
-
- (let ((internal (package-internal-symbols package))
- (external (package-external-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)
- (nuke-symbol external (symbol-name sym))))
+ (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
+ "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))
- (syms ())
- (cset ()))
- (dolist (sym symbols)
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (cond ((not w)
- (let ((found (member sym syms :test #'string=)))
- (if found
- (when (not (eq (car found) sym))
- (push sym cset))
- (push sym syms))))
- ((not (eq s sym)) (push sym cset))
- ((eq w :inherited) (push sym syms)))))
- (when cset
- ;; ANSI specifies that this error is correctable.
- (with-simple-restart
- (continue "Import these symbols with Shadowing-Import.")
- (error 'simple-package-error
- :package package
- :format-control
- "Importing these symbols into the ~A package ~
- causes a name conflict:~%~S"
- :format-arguments (list (package-%name package) cset))))
- ;; Add the new symbols to the internal hashtable.
- (let ((internal (package-internal-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)))
- ;; If any of the symbols are uninterned, make them be owned by Package.
- (dolist (sym symbols)
- (unless (symbol-package sym) (%set-symbol-package sym package)))
- (shadowing-import cset package)))
+ (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)))
\f
;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
(defun shadowing-import (symbols &optional (package (sane-package)))
#!+sb-doc
- "Import Symbols into package, disregarding any name conflict. If
- a symbol of the same name is present, then it is uninterned.
- The symbols are added to the Package-Shadowing-Symbols."
+ "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)))
- (dolist (sym (symbol-listify symbols))
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (unless (and w (not (eq w :inherited)) (eq s sym))
- (when (or (eq w :internal) (eq w :external))
- ;; If it was shadowed, we don't want UNINTERN to flame out...
- (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)))))
+ (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))))))
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, adding the new symbols to the Package-Shadowing-Symbols.
- If a symbol with the given name is already present in Package, then
- the existing symbol is placed in the shadowing symbols list if it is
- not already present."
+ "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)))
- (dolist (name (mapcar #'string
- (if (listp symbols) symbols (list symbols))))
- (multiple-value-bind (s w) (find-symbol name package)
- (when (or (not w) (eq w :inherited))
- (setq s (make-symbol name))
- (%set-symbol-package s package)
- (add-symbol internal s))
- (pushnew s (package-%shadowing-symbols 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
+ "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."
+ 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...
- (dolist (pkg packages)
- (unless (member pkg (package-%use-list package))
- (let ((cset ())
- (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 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)))
- (push sym cset))))
- (dolist (p use-list)
- (do-external-symbols (sym p)
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) pkg)
- (when (and w (not (eq s sym))
- (not (member (find-symbol (symbol-name sym)
- package)
- shadowing-symbols)))
- (push sym cset))))))
- (t
- (do-external-symbols (sym pkg)
- (multiple-value-bind (s w)
- (find-symbol (symbol-name sym) package)
- (when (and w (not (eq s sym))
- (not (member s shadowing-symbols)))
- (push s cset))))))
-
- (when cset
- (cerror
- "Unintern the conflicting symbols in the ~2*~A package."
- "Use'ing package ~A results in name conflicts for these symbols:~%~S"
- (package-%name pkg) cset (package-%name package))
- (dolist (s cset) (moby-unintern s package))))
-
- (push pkg (package-%use-list package))
- (push (package-external-symbols pkg) (cdr (package-tables package)))
- (push package (package-%used-by-list pkg)))))
+ (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
+ (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)))
- (dolist (p (package-listify packages-to-unuse))
- (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)))))
+ (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)
(do-symbols (symbol package)
(when (and (eq (symbol-package symbol) package)
(or (not external-only)
- (eq (find-symbol (symbol-name symbol) package)
+ (eq (nth-value 1 (find-symbol (symbol-name symbol)
+ package))
:external))
(search string (symbol-name symbol) :test #'char-equal))
(push symbol result)))
(add-symbol external symbol))
;; Put shadowing symbols in the shadowing symbols list.
- (setf (package-%shadowing-symbols pkg) (sixth spec))))
+ (setf (package-%shadowing-symbols pkg) (sixth spec))
+ ;; Set the package documentation
+ (setf (package-doc-string pkg) (seventh spec))))
;; FIXME: These assignments are also done at toplevel in
;; boot-extensions.lisp. They should probably only be done once.
projects / sbcl.git / blobdiff