X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=ff0bd1467a7c0c6ea83e56f2ec0d902777a8463a;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=d4876eff603ea3a5444f0d05a081bb5ecd011729;hpb=81880593109f9f359cd06dc5c4323750ccc2bf21;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index d4876ef..ff0bd14 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -51,11 +51,17 @@ (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, @@ -327,7 +333,8 @@ error if any of PACKAGES is not a valid package designator." (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 @@ -352,30 +359,31 @@ error if any of PACKAGES is not a valid package designator." (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. @@ -469,10 +477,10 @@ error if any of PACKAGES is not a valid package designator." `(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 @@ -503,7 +511,8 @@ error if any of PACKAGES is not a valid package designator." (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) @@ -519,10 +528,10 @@ error if any of PACKAGES is not a valid package designator." (when (< used (truncate size 4)) (resize-package-hashtable table (* used 2))))) -;;; 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)) @@ -584,7 +593,7 @@ implementation it is ~S." *default-package-use-list*) ;; 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 @@ -623,7 +632,7 @@ implementation it is ~S." *default-package-use-list*) (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) @@ -763,7 +772,7 @@ implementation it is ~S." *default-package-use-list*) (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 @@ -802,7 +811,8 @@ implementation it is ~S." *default-package-use-list*) (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)))) @@ -837,7 +847,7 @@ implementation it is ~S." *default-package-use-list*) (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 () @@ -858,102 +868,32 @@ implementation it is ~S." *default-package-use-list*) (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. @@ -1048,8 +988,7 @@ uninterned." (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) @@ -1059,10 +998,7 @@ uninterned." (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 ())) @@ -1339,10 +1275,10 @@ PACKAGE." :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 @@ -1407,7 +1343,7 @@ PACKAGE." (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,