common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Revert "Make test BLOCK-DEFPACKAGE-RENAME-PACKAGE work."

Browse source 
This reverts commit a73445b84d.

It doesn't handle symbol conflicts properly.
This commit is contained in:
Charles Zhang 2022-06-02 22:16:01 -07:00
parent 3d71e628f1
commit 113d482314
2 changed files with 11 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
src/code/target-package.lisp
View file

@ -989,19 +989,6 @@ Experimental: interface subject to change."
"~S is already a nickname for ~S."
nickname (package-%name found)))))))
;;; Set the home package of each symbol in package OLD to NEW. NEW may
;;; be NULL to indicate deletion.
(defun rehome-package-symbols (old new)
(declare (type package old)
(type (or null package) new))
(flet ((rehome (symbols)
(dovector (x (package-hashtable-cells symbols))
(when (and (symbolp x)
(eq (symbol-package x) old))
(%set-symbol-package x new)))))
(rehome (package-internal-symbols old))
(rehome (package-external-symbols old))))
;;; ANSI specifies that:
;;; (1) MAKE-PACKAGE and DEFPACKAGE use the same default package-use-list
;;; (2) that it (as an implementation-defined value) should be documented,
@ -1143,31 +1130,6 @@ implementation it is ~S." *!default-package-use-list*)
(assert-package-unlocked
package "renaming as ~A~@[ with nickname~*~P ~1@*~{~A~^, ~}~]"
name nicks (length nicks)))
;; If a loader package exists, resolve it and have the
;; package-to-be renamed take on the resolved packages
;; symbols, so that it gets cleaned up.
(let ((loader-package
(or (resolve-deferred-package name)
(resolve-rehoming-package name))))
(when loader-package
(let ((loader-internals (package-internal-symbols
loader-package))
(loader-externals (package-external-symbols
loader-package))
(package-internals (package-internal-symbols
package))
(package-externals (package-external-symbols
package)))
;; FIXME: What should/can we do with conflicts?
(dovector (x (package-hashtable-cells loader-internals))
(when (and (symbolp x)
(eq (symbol-package x) loader-package))
(add-symbol package-internals x)))
(dovector (x (package-hashtable-cells loader-externals))
(when (and (symbolp x)
(eq (symbol-package x) loader-package))
(add-symbol package-externals x))))
(rehome-package-symbols loader-package package)))
(with-package-names (table)
;; Check for race conditions now that we have the lock.
(unless (eq package (find-package package-designator))
@ -1231,7 +1193,14 @@ implementation it is ~S." *!default-package-use-list*)
(dolist (used (package-use-list package))
(unuse-package used package))
(setf (package-%local-nicknames package) nil)
(rehome-package-symbols package (make-rehoming-package package))
(let ((rehoming-package (make-rehoming-package package)))
(flet ((nullify-home (symbols)
(dovector (x (package-hashtable-cells symbols))
(when (and (symbolp x)
(eq (symbol-package x) package))
(%set-symbol-package x rehoming-package)))))
(nullify-home (package-internal-symbols package))
(nullify-home (package-external-symbols package))))
(with-package-names (table)
(awhen (package-id package)
(setf (aref *id->package* it) nil (package-id package) nil))

4
tests/block-compile.impure.lisp
View file

@ -102,7 +102,9 @@
(assert (eq (nth-value 1 (find-symbol "F" "BLOCK-DEFPACKAGE4"))
:external)))
(with-test (:name :block-defpackage-rename-package)
;;; Doesn't work yet.
(with-test (:name :block-defpackage-rename-package
:fails-on :sbcl)
(ctu:file-compile
`((eval-when (:compile-toplevel :load-toplevel :execute)
(cond