diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index f459bdc76..14a46337e 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -33,11 +33,9 @@ The default value of USE is implementation-dependent, and in this implementation it is ~S." *!default-package-use-list*) (prog ((name (stringify-string-designator name)) (nicks (stringify-string-designators nicknames)) - (package - (or (resolve-deferred-package name) - (resolve-rehoming-package name) - (%make-package (make-symbol-hashset internal-symbols) - (make-symbol-hashset external-symbols)))) + (package (%make-package + (make-symbol-hashset internal-symbols) + (make-symbol-hashset external-symbols))) clobber) :restart (when (find-package name) @@ -203,14 +201,12 @@ implementation it is ~S." *!default-package-use-list*) (dolist (used (package-use-list package)) (unuse-package used package)) (setf (package-%local-nicknames package) nil) - (let ((rehoming-package (make-rehoming-package package))) - (flet ((nullify-home (symbols) - (dovector (x (symtbl-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)))) + (flet ((nullify-home (symbols) + (dovector (x (symtbl-cells symbols)) + (when (and (symbolp x) (eq (symbol-package x) package)) + (%set-symbol-package x nil))))) + (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)) diff --git a/src/code/load.lisp b/src/code/load.lisp index 9e8dec0ca..c7805368b 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -731,13 +731,12 @@ (error "attempt to load an empty FASL file:~% ~S" (namestring stream))) (maybe-announce-load stream verbose) (let ((fasl-input (make-fasl-input stream print))) - (with-loader-package-names - (unwind-protect - (loop while (load-fasl-group fasl-input)) - ;; Nuke the table and stack to avoid keeping garbage on - ;; conservatively collected platforms. - (nuke-fop-vector (%fasl-input-table fasl-input)) - (nuke-fop-vector (%fasl-input-stack fasl-input))))) + (unwind-protect + (loop while (load-fasl-group fasl-input)) + ;; Nuke the table and stack to avoid keeping garbage on + ;; conservatively collected platforms. + (nuke-fop-vector (%fasl-input-table fasl-input)) + (nuke-fop-vector (%fasl-input-stack fasl-input)))) t) @@ -889,8 +888,7 @@ (define-fop 83 :not-host (fop-named-package-save ((:operands length)) nil) (let ((package-name (make-string length))) (read-char-string-as-varints (fasl-input-stream) package-name) - (push-fop-table (find-or-maybe-make-deferred-package package-name) - (fasl-input)))) + (push-fop-table (find-package package-name) (fasl-input)))) ;;;; fops for loading numbers diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index a94db7bb4..e562cbe89 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -2038,100 +2038,6 @@ PACKAGE." (or (null pkg) (and (packagep pkg) (package-%name pkg))))) -;;;; special package hacks for the loader - -(defvar *deferred-package-names*) - -;;; A deferred package is a package which is not added to the normal -;;; package database until some later point in time. The current -;;; purpose for deferred packages is so that the loader symbol fasl -;;; ops can intern symbols into packages, without the packages -;;; necessarily being created yet. This is important for deferred -;;; top-level form loading, as to not cause loading symbols (which may -;;; appear as literal code constants) to fail early. Since the -;;; deferred package is not added to the normal package database until -;;; the package is actually created, we preserve package environment -;;; semantics at runtime, and give a reasonable error if the package -;;; has not been created by the end of the load. -(defun find-or-maybe-make-deferred-package (name) - (or (find-package name) - (progn - (unless *deferred-package-names* ; bind on demand - (setq *deferred-package-names* - (make-info-hashtable :comparator #'pkg-name= - :hash-function #'sxhash))) - (or (%get-package name *deferred-package-names*) - (let ((package (%make-package (make-symbol-hashset 0) - (make-symbol-hashset 0)))) - (%register-package *deferred-package-names* name package) - (setf (package-%name package) name) - package))))) - -;;; Return the deferred package object for NAME if it exists, otherwise -;;; return NIL. -(defun resolve-deferred-package (name) - (and (boundp '*deferred-package-names*) - *deferred-package-names* - (let ((package (%get-package name *deferred-package-names*))) - (when package - ;; To simulate remhash. - (setf (info-gethash name *deferred-package-names*) :deleted)) - package))) - -(defvar *rehoming-package-names*) - -;;; When we are in the loader, DELETE-PACKAGE installs a rehoming -;;; package in the SYMBOL-PACKAGE of its internal symbols. This has -;;; the effect that when a package of the same name is newly redefined -;;; later in the compiled file, the package gets updated and those -;;; internal symbols get rehomed properly. -(defun make-rehoming-package (package) - (and (boundp '*rehoming-package-names*) - (let ((name (package-%name package))) - (unless *rehoming-package-names* ; bind on demand - (setq *rehoming-package-names* - (make-info-hashtable :comparator #'pkg-name= - :hash-function #'sxhash))) - (aver (not (%get-package name *rehoming-package-names*))) - (let ((package (%make-package (package-internal-symbols package) - (package-external-symbols package)))) - (%register-package *rehoming-package-names* name package) - (setf (package-%name package) name) - package)))) - -;;; Return the rehoming object for NAME if it exists, otherwise return -;;; NIL. -(defun resolve-rehoming-package (name) - (and (boundp '*rehoming-package-names*) - *rehoming-package-names* - (let ((package (%get-package name *rehoming-package-names*))) - (when package - ;; To simulate remhash. - (setf (info-gethash name *rehoming-package-names*) :deleted)) - package))) - -;;; Bind the deferred and rehoming package name tables and test to see -;;; if the deferred package table still has any unresolved entries -;;; after FUNCTION is called. -(defun call-with-loader-package-names (function) - (let* ((boundp (boundp '*deferred-package-names*)) - ;; bind on demand - (*deferred-package-names* (if boundp *deferred-package-names* nil)) - (*rehoming-package-names* (if boundp *rehoming-package-names* nil))) - (funcall function) - (when (and (not boundp) *deferred-package-names*) - (info-maphash - (lambda (name package) - (unless (eq package :deleted) - (dovector (sym (symtbl-cells (package-internal-symbols package))) - (when (symbolp sym) - (error 'simple-package-error - :format-control - "The loader tried loading the symbol named ~a ~ - into the package named ~a, but the package did ~ - not get defined, and does not exist." - :format-arguments (list (symbol-name sym) name)))))) - *deferred-package-names*)))) ;;; We don't benefit from these transforms because any time we have a constant ;;; package in our code, we refer to it via #.(FIND-PACKAGE). diff --git a/tests/block-compile.impure.lisp b/tests/block-compile.impure.lisp index 55e306595..a1bfce9a1 100644 --- a/tests/block-compile.impure.lisp +++ b/tests/block-compile.impure.lisp @@ -17,7 +17,8 @@ (assert (not (ctu:find-named-callees (symbol-function 'bar-with-foo-inline)))) (assert (ctu:find-named-callees (symbol-function 'bar-with-foo-call)))) -(with-test (:name :block-defpackage-then-load-fasl) +(with-test (:name :block-defpackage-then-load-fasl + :fails-on :sbcl) (ctu:file-compile `((defpackage block-defpackage (:use :cl :cl-user)) @@ -66,7 +67,8 @@ (defpackage block-defpackage3 (:use :cl)) -(with-test (:name :block-defpackage-delete-package-redefpackage) +(with-test (:name :block-defpackage-delete-package-redefpackage + :fails-on :sbcl) (ctu:file-compile `((when (find-package '#:block-defpackage3) (delete-package '#:block-defpackage3)) diff --git a/tests/package-test-5.lisp b/tests/package-test-5.lisp new file mode 100644 index 000000000..d4a9dce61 --- /dev/null +++ b/tests/package-test-5.lisp @@ -0,0 +1,18 @@ +(defun foo.delete-package-redefpackage () + (let ((package (find-package :bar-drrfl))) + (when package + (let ((count 0)) + (do-symbols (sym package) + (incf count)) + (assert (= count 2)) + (delete-package package)))) + (make-package "BAR-DRRFL" :use ()) + (let ((package (find-package :bar-drrfl)) + (count 0)) + (do-symbols (sym package) + (incf count)) + (assert (= count 0)) + (eval (read-from-string + "(progn + (defun bar-drrfl::a ()) + (defun bar-drrfl::b ()))")))) diff --git a/tests/package-test-6.lisp b/tests/package-test-6.lisp new file mode 100644 index 000000000..adbad1aff --- /dev/null +++ b/tests/package-test-6.lisp @@ -0,0 +1 @@ +(foo.delete-package-redefpackage) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index cc539c70d..f9c03c9a4 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -1133,3 +1133,14 @@ if a restart was invoked." (assert (eq (nth-value 1 (find-symbol "BAR" "FOO-NEW")) :external)) (delete-package "FOO-NEW")) + +(with-test (:name :defpackage-delete-package-redefpackage-fasloader) + (with-scratch-file (fasl5 "fasl") + (compile-file "package-test-5.lisp" :output-file fasl5) + (load fasl5) + (if (find-package "BAR-DRRFL") (delete-package "BAR-DRRFL")) + (with-scratch-file (fasl6 "fasl") + (compile-file "package-test-6.lisp" :output-file fasl6) + (load fasl6) + (load fasl6)) + (delete-package "BAR-DRRFL")))