Raymond Toy pushed to branch master at cmucl / cmucl Commits: f0a597b9 by Raymond Toy at 2026-06-26T15:57:48-07:00 Fix #500: Refactor package-locked-error handling - - - - - 9b6135db by Raymond Toy at 2026-06-26T15:57:48-07:00 Merge branch 'issue-500-common-package-error-restart-function' into 'master' Fix #500: Refactor package-locked-error handling Closes #500 See merge request cmucl/cmucl!376 - - - - - 5 changed files: - src/code/defstruct.lisp - src/code/macros.lisp - src/code/package.lisp - src/i18n/locale/cmucl.pot - + tests/package-lock.lisp Changes: ===================================== src/code/defstruct.lisp ===================================== @@ -452,25 +452,11 @@ name-and-options))) (name (dd-name defstruct)) (pkg (symbol-package name))) - (when (and lisp::*enable-package-locked-errors* - pkg + (when (and pkg (ext:package-definition-lock pkg)) - (restart-case - (error 'lisp::package-locked-error - :package pkg - :format-control (intl:gettext "defining structure ~A") - :format-arguments (list name)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's definition lock then continue") stream)) - (setf (ext:package-definition-lock pkg) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (lisp::unlock-all-packages)))) + (lisp::signal-package-locked-error pkg :definition + (intl:gettext "defining structure ~A") + name)) (when (info declaration recognized name) (error (intl:gettext "Defstruct already names a declaration: ~S.") name)) (when (stringp (car slot-descriptions)) ===================================== src/code/macros.lisp ===================================== @@ -221,6 +221,13 @@ "Syntax like DEFMACRO, but defines a new type." (unless (symbolp name) (simple-program-error (intl:gettext "~S -- Type name not a symbol.") name)) + (let ((pkg (symbol-package name))) + (when (and pkg (ext:package-definition-lock pkg)) + (signal-package-locked-error pkg :definition + (intl:gettext "defining type ~A") + name))) + + #+nil (and lisp::*enable-package-locked-errors* (symbol-package name) (ext:package-definition-lock (symbol-package name)) ===================================== src/code/package.lisp ===================================== @@ -189,8 +189,46 @@ (ext:compiler-let ((*enable-package-locked-errors* nil)) ,@body)))) - -;; trap attempts to redefine a function in a locked package, and +;;; SIGNAL-PACKAGE-LOCKED-ERROR -- Internal +;;; +;;; This encapsulates signaling of package locked errors. LOCK-KIND +;;; should be one of the following which will clear the corresponding +;;; lock when the UNLOCK-PACKAGE restart is selected. +;;; +;;; :definition - resets package-definition-lock +;;; :namespace - resets package-lock +;;; +;;; Error is signaled only if *ENABLE-PACKAGE-LOCKED-ERRORS* is non-NIL. +(defun signal-package-locked-error (package lock-kind message-control &rest message-args) + (declare (type (member :definition :namespace) lock-kind)) + ;; During bootstrap, *ENABLE-PACKAGE-LOCKED-ERRORS* may not be + ;; bound. Treat that is if it were NIL, so nothing is signaled. + (when (and (boundp '*enable-package-locked-errors*) + *enable-package-locked-errors*) + (restart-case + (error 'lisp::package-locked-error + :package package + :format-control message-control + :format-arguments message-args) + (continue () + :report (lambda (stream) + (write-string (intl:gettext "Ignore the lock and continue") + stream))) + (unlock-package () + :report (lambda (stream) + (write-string (intl:gettext "Disable the package's definition-lock then continue") + stream)) + (ecase lock-kind + (:definition + (setf (ext:package-definition-lock package) nil)) + (:namespace + (setf (ext:package-lock package) nil)))) + (unlock-all () + :report (lambda (stream) + (write-string (intl:gettext "Unlock all packages, then continue") stream)) + (unlock-all-packages))))) + +;; Trap attempts to redefine a function in a locked package, and ;; signal a continuable error. (defun redefining-function (function replacement) (declare (ignore replacement)) @@ -201,30 +239,16 @@ (let ((package (symbol-package block-name))) (when package (when (package-definition-lock package) - (when (and (consp function) - (member (first function) - '(pcl::slot-accessor - pcl::method - pcl::fast-method - pcl::effective-method - pcl::ctor))) - (return-from redefining-function nil)) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "redefining function ~A") - :format-arguments (list function)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's definition-lock, then continue") stream)) - (setf (ext:package-definition-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Disable all package locks, then continue") stream)) - (unlock-all-packages))))))))) + (unless (and (consp function) + (member (first function) + '(pcl::slot-accessor + pcl::method + pcl::fast-method + pcl::effective-method + pcl::ctor))) + (signal-package-locked-error package :definition + (intl:gettext "redefining function ~A") + function)))))))) ;;; This magical variable is T during initialization so Use-Package's of packages @@ -1438,24 +1462,10 @@ (name (symbol-name symbol)) (shadowing-symbols (package-%shadowing-symbols package))) (declare (list shadowing-symbols) (simple-string name)) - (when *enable-package-locked-errors* - (when (ext:package-lock package) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "uninterning symbol ~A") - :format-arguments (list name)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's lock then continue") stream)) - (setf (ext:package-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (unlock-all-packages))))) + (when (ext:package-lock package) + (signal-package-locked-error package :namespace + (intl:gettext "uninterning symbol ~A") + name)) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. @@ -1620,24 +1630,11 @@ "Makes SYMBOLS no longer exported from PACKAGE." (let ((package (package-or-lose package)) (syms ())) - (when *enable-package-locked-errors* - (when (ext:package-lock package) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "unexporting symbols ~A") - :format-arguments (list symbols)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's lock then continue") stream)) - (setf (ext:package-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (unlock-all-packages))))) + (when (ext:package-lock package) + (signal-package-locked-error package :namespace + (intl:gettext "unexporting symbols ~A") + symbols)) + (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8196,20 +8196,20 @@ msgstr "" msgid "~&~@<Attempt to modify the locked package ~A, by ~3i~:_~?~:>" msgstr "" -#: src/code/package.lisp -msgid "redefining function ~A" +#: src/code/macros.lisp src/code/package.lisp +msgid "Ignore the lock and continue" msgstr "" -#: src/code/macros.lisp src/code/defstruct.lisp src/code/package.lisp -msgid "Ignore the lock and continue" +#: src/code/macros.lisp src/code/package.lisp +msgid "Disable the package's definition-lock then continue" msgstr "" -#: src/code/package.lisp -msgid "Disable package's definition-lock, then continue" +#: src/code/macros.lisp src/code/package.lisp +msgid "Unlock all packages, then continue" msgstr "" #: src/code/package.lisp -msgid "Disable all package locks, then continue" +msgid "redefining function ~A" msgstr "" #: src/code/package.lisp @@ -8459,14 +8459,6 @@ msgstr "" msgid "uninterning symbol ~A" msgstr "" -#: src/code/package.lisp -msgid "Disable package's lock then continue" -msgstr "" - -#: src/code/macros.lisp src/code/defstruct.lisp src/code/package.lisp -msgid "Unlock all packages, then continue" -msgstr "" - #: src/code/package.lisp msgid "prompt for a symbol to shadowing-import." msgstr "" @@ -14472,10 +14464,6 @@ msgstr "" msgid "defining structure ~A" msgstr "" -#: src/code/defstruct.lisp -msgid "Disable package's definition lock then continue" -msgstr "" - #: src/code/defstruct.lisp msgid "Defstruct already names a declaration: ~S." msgstr "" @@ -14832,10 +14820,6 @@ msgstr "" msgid "defining macro ~A" msgstr "" -#: src/code/macros.lisp -msgid "Disable the package's definition-lock then continue" -msgstr "" - #: src/code/macros.lisp msgid "Define a compiler-macro for NAME." msgstr "" @@ -14868,10 +14852,6 @@ msgstr "" msgid "defining type ~A" msgstr "" -#: src/code/macros.lisp -msgid "Disable package's definition-lock then continue" -msgstr "" - #: src/code/macros.lisp msgid "Deftype already names a declaration: ~S." msgstr "" ===================================== tests/package-lock.lisp ===================================== @@ -0,0 +1,91 @@ +;;; Regression tests for package-locked-error signaling. +;;; +;;; These tests exist as a baseline before refactoring the +;;; package-lock checks into a shared helper. They verify that +;;; package-locked-error is signaled at each call site we expect to +;;; check the lock; restart behavior is tested separately. + +(defpackage :package-lock-tests + (:use :cl :lisp-unit)) + +(in-package "PACKAGE-LOCK-TESTS") + +(defpackage :test-locked-package + (:use :cl)) + +(defmacro with-definition-locked ((package) &body body) + "Run BODY with PACKAGE's definition-lock enabled and namespace-lock + disabled, so failures from BODY can be attributed unambiguously to + the definition lock." + `(let ((p ,package)) + (setf (ext:package-definition-lock p) t + (ext:package-lock p) nil) + (assert-true (ext:package-definition-lock p)) + (assert-false (ext:package-lock p)) + (unwind-protect (progn ,@body) + (setf (ext:package-definition-lock p) nil + (ext:package-lock p) nil)))) + +(defmacro with-namespace-locked ((package) &body body) + "Run BODY with PACKAGE's namespace-lock enabled and definition-lock + disabled, so failures from BODY can be attributed unambiguously to + the namespace lock." + `(let ((p ,package)) + (setf (ext:package-definition-lock p) nil + (ext:package-lock p) t) + (assert-false (ext:package-definition-lock p)) + (assert-true (ext:package-lock p)) + (unwind-protect (progn ,@body) + (setf (ext:package-definition-lock p) nil + (ext:package-lock p) nil)))) + + +;;; ---- Definition-lock tests ---- + +(define-test package-locked.defmacro + (:tag :issues) + (with-definition-locked ((find-package :test-locked-package)) + (assert-error 'lisp::package-locked-error + (eval '(defmacro test-locked-package::a-macro (x) + `(list ,x)))))) + +(define-test package-locked.defun + (:tag :issues) + (with-definition-locked ((find-package :test-locked-package)) + (assert-error 'lisp::package-locked-error + (eval '(defun test-locked-package::a-fn (x) x))))) + +(define-test package-locked.deftype + (:tag :issues) + (with-definition-locked ((find-package :test-locked-package)) + (assert-error 'lisp::package-locked-error + (eval '(deftype test-locked-package::a-type () + 'integer))))) + +(define-test package-locked.defstruct + (:tag :issues) + (with-definition-locked ((find-package :test-locked-package)) + (assert-error 'lisp::package-locked-error + (eval '(defstruct test-locked-package::a-struct + slot-1 slot-2))))) + + +;;; ---- Namespace-lock tests ---- + +(define-test package-locked.unintern + (:tag :issues) + (let ((sym (intern "TO-BE-UNINTERNED" + (find-package :test-locked-package)))) + (with-namespace-locked ((find-package :test-locked-package)) + (assert-error 'lisp::package-locked-error + (unintern sym (find-package :test-locked-package)))))) + +(define-test package-locked.unexport + (:tag :issues) + (let* ((p (find-package :test-locked-package)) + (sym (intern "TO-BE-UNEXPORTED" p))) + (export sym p) + (with-namespace-locked (p) + (assert-error 'lisp::package-locked-error + (unexport sym p))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5926490b13936966d04811e... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5926490b13936966d04811e... You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help