X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=88b3cbf69de71c6e8c75ac731688988ae48be46b;hb=af178240ffbda39e9c3bf584ad8ed0adcf4b6abd;hp=6e64443f4f886d403293ddbcb8f1551ecf7031f0;hpb=f5fff2abb7de72d52905253a664cff2f80b6a617;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 6e64443..88b3cbf 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -8,6 +8,9 @@ ;;;; 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. @@ -24,14 +27,6 @@ (!cold-init-forms (/show0 "entering !PACKAGE-COLD-INIT")) - -(defvar *default-package-use-list*) -(!cold-init-forms - (setf *default-package-use-list* '("COMMON-LISP"))) -#!+sb-doc -(setf (fdocumentation '*default-package-use-list* 'variable) - "the list of packages to use by default when no :USE argument is supplied - to MAKE-PACKAGE or other package creation forms") ;;;; PACKAGE-HASHTABLE stuff @@ -54,22 +49,212 @@ ;;; 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))) + +;;;; 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) + ;;;; miscellaneous PACKAGE operations @@ -84,23 +269,19 @@ ;;; 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-frob (ext real) +(macrolet ((def (ext real) `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) - (def-frob package-nicknames package-%nicknames) - (def-frob package-use-list package-%use-list) - (def-frob package-used-by-list package-%used-by-list) - (def-frob package-shadowing-symbols package-%shadowing-symbols)) + (def package-nicknames package-%nicknames) + (def package-use-list package-%use-list) + (def package-used-by-list package-%used-by-list) + (def package-shadowing-symbols package-%shadowing-symbols)) (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))) @@ -135,12 +316,29 @@ (!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))) @@ -194,9 +392,7 @@ (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) @@ -210,19 +406,18 @@ (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) @@ -233,9 +428,7 @@ (,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)) @@ -245,8 +438,7 @@ (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 @@ -287,32 +479,32 @@ (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*) + (use '#.*default-package-use-list*) nicknames (internal-symbols 10) (external-symbols 10)) #!+sb-doc - "Makes a new package having the specified Name and Nicknames. The - package will inherit all external symbols from each package in - the use list. :Internal-Symbols and :External-Symbols are + #.(format nil + "Make a new package having the specified NAME, NICKNAMES, and + USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are estimates for the number of internal and external symbols which - will ultimately be present in the package." + will ultimately be present in the package. The default value of + USE is implementation-dependent, and in this implementation + it is ~S." + *default-package-use-list*) ;; Check for package name conflicts in name and nicknames, then ;; make the package. @@ -357,99 +549,120 @@ #!+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 + "~@" + :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 "Return a list of all existing packages." (let ((res ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (pushnew v res)) + (maphash (lambda (k v) + (declare (ignore k)) + (pushnew v res)) *package-names*) res)) (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 @@ -465,16 +678,20 @@ (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 @@ -503,7 +720,7 @@ (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) @@ -516,55 +733,179 @@ string length hash ehash) (values symbol found)))) +(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* "~&~@