(defvar *package-lock*)
(!cold-init-forms
- (setf *package-lock* (sb!thread::make-spinlock :name "Package Lock")))
+ (setf *package-lock* (sb!thread:make-mutex :name "Package Lock")))
-(defmacro with-packages ((&key) &body forms)
- `(sb!thread::with-recursive-spinlock (*package-lock*)
- ,@forms))
+(defun call-with-packages (function)
+ (declare (function function))
+ ;; FIXME: Since name conflicts can be signalled while holding the
+ ;; mutex, user code can be run leading to lock ordering problems.
+ ;;
+ ;; This used to be a spinlock, but there it can be held for a long
+ ;; time while the debugger waits for user input.
+ (sb!thread:with-recursive-lock (*package-lock*)
+ (funcall function)))
;;; Make a package hashtable having a prime number of entries at least
;;; as great as (/ SIZE +PACKAGE-REHASH-THRESHOLD+). If RES is supplied,
(defvar *package-names*)
(declaim (type hash-table *package-names*))
(!cold-init-forms
- (setf *package-names* (make-hash-table :test 'equal)))
+ ;; No lock, accesses are synchonized on WITH-PACKAGES.
+ (setf *package-names* (make-hash-table :test 'equal)))
;;; This magical variable is T during initialization so that
;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such
(find-restart-or-control-error 'debootstrap-package condition)))
(defun find-package (package-designator)
- (flet ((find-package-from-string (string)
- (declare (type string string))
- (let ((packageoid (gethash string *package-names*)))
- (when (and (null packageoid)
- (not *in-package-init*) ; KLUDGE
- (let ((mismatch (mismatch "SB!" string)))
- (and mismatch (= mismatch 3))))
- (restart-case
- (signal 'bootstrap-package-not-found :name string)
- (debootstrap-package ()
- (return-from find-package
- (if (string= string "SB!XC")
- (find-package "COMMON-LISP")
- (find-package
- (substitute #\- #\! string :count 1)))))))
- packageoid)))
- (typecase package-designator
- (package package-designator)
- (symbol (find-package-from-string (symbol-name package-designator)))
- (string (find-package-from-string package-designator))
- (character (find-package-from-string (string package-designator)))
- (t (error 'type-error
- :datum package-designator
- :expected-type '(or character package string symbol))))))
+ (with-packages ()
+ (flet ((find-package-from-string (string)
+ (declare (type string string))
+ (let ((packageoid (gethash string *package-names*)))
+ (when (and (null packageoid)
+ (not *in-package-init*) ; KLUDGE
+ (let ((mismatch (mismatch "SB!" string)))
+ (and mismatch (= mismatch 3))))
+ (restart-case
+ (signal 'bootstrap-package-not-found :name string)
+ (debootstrap-package ()
+ (return-from find-package
+ (if (string= string "SB!XC")
+ (find-package "COMMON-LISP")
+ (find-package
+ (substitute #\- #\! string :count 1)))))))
+ packageoid)))
+ (typecase package-designator
+ (package package-designator)
+ (symbol (find-package-from-string (symbol-name package-designator)))
+ (string (find-package-from-string package-designator))
+ (character (find-package-from-string (string package-designator)))
+ (t (error 'type-error
+ :datum package-designator
+ :expected-type '(or character package string symbol)))))))
;;; Return a list of packages given a package designator or list of
;;; package designators, or die trying.
`(let* ((,vec (package-hashtable-table ,table))
(,hash (package-hashtable-hash ,table))
(,len (length ,vec))
- (,h2 (1+ (the index (rem (the index ,sxhash)
+ (,h2 (1+ (the index (rem (the hash ,sxhash)
(the index (- ,len 2)))))))
(declare (type index ,len ,h2))
- (prog ((,index-var (rem (the index ,sxhash) ,len))
+ (prog ((,index-var (rem (the hash ,sxhash) ,len))
,symbol-var ,ehash)
(declare (type (or index null) ,index-var))
LOOP
(let* ((length (length string))
(hash (%sxhash-simple-string string))
(ehash (entry-hash length hash)))
- (declare (type index length hash))
+ (declare (type index length)
+ (type hash hash))
(with-symbol (index symbol table string length hash ehash)
(setf (aref (package-hashtable-hash table) index) 1)
(setf (aref (package-hashtable-table table) index) nil)
(when (< used (truncate size 4))
(resize-package-hashtable table (* used 2)))))
\f
-;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*.
-;;; If there is a conflict then give the user a chance to do
-;;; something about it.
-(defun enter-new-nicknames (package nicknames)
+;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*. If there is a
+;;; conflict then give the user a chance to do something about it. Caller is
+;;; responsible for having acquired the mutex via WITH-PACKAGES.
+(defun %enter-new-nicknames (package nicknames)
(declare (type list nicknames))
(dolist (n nicknames)
(let* ((n (package-namify n))
;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before
;; USE-PACKAGE, but I need to check what kinds of errors can be caused by
;; USE-PACKAGE, too.
- (enter-new-nicknames package nicknames)
+ (%enter-new-nicknames package nicknames)
(setf (gethash name *package-names*) package))))
;;; Change the name if we can, blast any old nicknames and then
(setf (package-%name package) name
(gethash name *package-names*) package
(package-%nicknames package) ())
- (enter-new-nicknames package nicknames))
+ (%enter-new-nicknames package nicknames))
package)))
(defun delete-package (package-designator)
(type index length))
(let* ((hash (%sxhash-simple-substring string length))
(ehash (entry-hash length hash)))
- (declare (type index hash ehash))
+ (declare (type hash hash ehash))
(with-symbol (found symbol (package-internal-symbols package)
string length hash ehash)
(when found
(let* ((length (length string))
(hash (%sxhash-simple-string string))
(ehash (entry-hash length hash)))
- (declare (type index length hash))
+ (declare (type index length)
+ (type hash hash))
(with-symbol (found symbol (package-external-symbols package)
string length hash ehash)
(values symbol found))))
(restart-case
(error 'name-conflict :package package :symbols symbols
:function function :datum datum)
- (resolve-conflict (s)
+ (resolve-conflict (chosen-symbol)
:report "Resolve conflict."
:interactive
(lambda ()
(let ((i (parse-integer (read-line *query-io*) :junk-allowed t)))
(when (and i (<= 1 i len))
(return (list (nth (1- i) symbols))))))))
- (multiple-value-bind (symbol status)
- (find-symbol (symbol-name s) package)
- (declare (ignore status)) ; FIXME: is that true?
- (case function
- ((export)
- (if (eq symbol s)
- (shadow symbol package)
- (unintern symbol package)))
- ((unintern)
- (shadowing-import s package))
- ((import)
- (if (eq symbol s)
- nil ; do nothing
- (shadowing-import s package)))
- ((use-package)
- (if (eq symbol s)
- (shadow s package)
- (shadowing-import s package))))))))
-
-#+nil ; this solution gives a variable number of restarts instead, but
- ; no good way of programmatically choosing between them.
-(defun name-conflict (package function datum &rest symbols)
- (let ((condition (make-condition 'name-conflict
- :package package :symbols symbols
- :function function :datum datum)))
- ;; this is a gross violation of modularity, but I can't see any
- ;; other way to have a variable number of restarts.
- (let ((*restart-clusters*
- (cons
- (mapcan
- (lambda (s)
- (multiple-value-bind (accessible-symbol status)
- (find-symbol (symbol-name s) package)
- (cond
- ;; difficult case
- ((eq s accessible-symbol)
- (ecase status
- ((:inherited)
- (list (make-restart
- :name (make-symbol "SHADOWING-IMPORT")
- :function (lambda ()
- (shadowing-import s package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream "Shadowing-import ~S into ~A."
- s (package-%name package))))))
- ((:internal :external)
- (aver (= (length symbols) 2))
- ;; ARGH! FIXME: this unintern restart can
- ;; _still_ leave the system in an
- ;; unsatisfactory state: if the symbol is a
- ;; external symbol of a package which is
- ;; already used by this package, and has also
- ;; been imported, then uninterning it from this
- ;; package will still leave it visible!
- ;;
- ;; (DEFPACKAGE "FOO" (:EXPORT "SYM"))
- ;; (DEFPACKAGE "BAR" (:EXPORT "SYM"))
- ;; (DEFPACKAGE "BAZ" (:USE "FOO"))
- ;; (IMPORT 'FOO:SYM "BAZ")
- ;; (USE-PACKAGE "BAR" "BAZ")
- ;;
- ;; Now (UNINTERN 'FOO:SYM "BAZ") doesn't
- ;; resolve the conflict. :-(
- ;;
- ;; -- CSR, 2004-10-20
- (list (make-restart
- :name (make-symbol "UNINTERN")
- :function (lambda ()
- (unintern s package)
- (import
- (find s symbols :test-not #'eq)
- package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream
- "Unintern ~S from ~A and import ~S."
- s
- (package-%name package)
- (find s symbols :test-not #'eq))))))))
- (t (list (make-restart
- :name (make-symbol "SHADOWING-IMPORT")
- :function (lambda ()
- (shadowing-import s package)
- (return-from name-conflict))
- :report-function
- (lambda (stream)
- (format stream "Shadowing-import ~S into ~A."
- s (package-%name package)))))))))
- symbols)
- *restart-clusters*)))
- (with-condition-restarts condition (car *restart-clusters*)
- (with-simple-restart (abort "Leave action undone.")
- (error condition))))))
+ (multiple-value-bind (package-symbol status)
+ (find-symbol (symbol-name chosen-symbol) package)
+ (let* ((accessiblep status) ; never NIL here
+ (presentp (and accessiblep
+ (not (eq :inherited status)))))
+ (ecase function
+ ((unintern)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ (shadow (list package-symbol) package)
+ (shadowing-import (list chosen-symbol) package))
+ (shadowing-import (list chosen-symbol) package)))
+ ((use-package export)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5
+ (if (eq (symbol-package package-symbol) package)
+ (unintern package-symbol package) ; CLHS 11.1.1.2.5
+ (shadowing-import (list chosen-symbol) package)))
+ (shadowing-import (list chosen-symbol) package)))
+ ((import)
+ (if presentp
+ (if (eq package-symbol chosen-symbol)
+ nil ; re-importing the same symbol
+ (shadowing-import (list chosen-symbol) package))
+ (shadowing-import (list chosen-symbol) package)))))))))
;;; If we are uninterning a shadowing symbol, then a name conflict can
;;; result, otherwise just nuke the symbol.
(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 ()))
+ (let ((used-by (package-%used-by-list package)))
(dolist (sym syms)
(let ((name (symbol-name sym)))
(dolist (p used-by)
(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))))
+ (name-conflict p 'export sym sym s)))))))
;; Check that all symbols are accessible. If not, ask to import them.
(let ((missing ())
(imports ()))
:external))
(search string (symbol-name symbol) :test #'char-equal))
(push symbol result)))
- result)
+ (sort result #'string-lessp))
(mapcan (lambda (package)
(apropos-list string-designator package external-only))
- (list-all-packages))))
+ (sort (list-all-packages) #'string-lessp :key #'package-name))))
(defun apropos (string-designator &optional package external-only)
#!+sb-doc
(setq *keyword-package* (find-package "KEYWORD"))
(/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
- (makunbound '*!initial-symbols*) ; (so that it gets GCed)
+ (%makunbound '*!initial-symbols*) ; (so that it gets GCed)
;; Make some other packages that should be around in the cold load.
;; The COMMON-LISP-USER package is required by the ANSI standard,