X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=01ed836da5c3cce40af70b9e4f4276737a9e2447;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=24af5a1537f488a9ef178795c2b6bddb9ea596ac;hpb=45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 24af5a1..01ed836 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -51,10 +51,15 @@ (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*) + ;; 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*) ,@forms)) ;;; Make a package hashtable having a prime number of entries at least @@ -469,10 +474,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 +508,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) @@ -763,7 +769,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 +808,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 +844,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 +865,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 +985,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 +995,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 +1272,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