Raymond Toy pushed to branch issue-500-common-package-error-restart-function at cmucl / cmucl Commits: e7c711a7 by Raymond Toy at 2026-05-02T18:02:25-07:00 Remove old code that was replaced by signal-package-locked-error - - - - - 3 changed files: - src/code/defstruct.lisp - src/code/package.lisp - src/code/type.lisp Changes: ===================================== src/code/defstruct.lisp ===================================== @@ -454,30 +454,9 @@ (pkg (symbol-package name))) (when (and pkg (ext:package-definition-lock pkg)) - (lisp::signal-package-locked-error - pkg :definition - (intl:gettext "defining structure ~A") - name)) - #+nil - (when (and lisp::*enable-package-locked-errors* - 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/package.lisp ===================================== @@ -191,10 +191,20 @@ ;;; SIGNAL-PACKAGE-LOCKED-ERROR -- Internal ;;; -;;; This encapsulates signaling of package locked errors. +;;; 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) - (when (and (boundp 'lisp::*enable-package-locked-errors*) - lisp::*enable-package-locked-errors*) + (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 @@ -218,43 +228,8 @@ (write-string (intl:gettext "Unlock all packages, then continue") stream)) (unlock-all-packages))))) -;; trap attempts to redefine a function in a locked package, and +;; Trap attempts to redefine a function in a locked package, and ;; signal a continuable error. -#+nil -(defun redefining-function (function replacement) - (declare (ignore replacement)) - (when *enable-package-locked-errors* - (multiple-value-bind (valid block-name) - (ext:valid-function-name-p function) - (declare (ignore valid)) - (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))))))))) - (defun redefining-function (function replacement) (declare (ignore replacement)) (when *enable-package-locked-errors* @@ -1491,25 +1466,6 @@ (signal-package-locked-error package :namespace (intl:gettext "uninterning symbol ~A") name)) - #+nil - (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))))) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. @@ -1678,25 +1634,7 @@ (signal-package-locked-error package :namespace (intl:gettext "unexporting symbols ~A") symbols)) - #+nil - (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))))) + (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/code/type.lisp ===================================== @@ -2950,6 +2950,7 @@ ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union ;;; type, and the member/union interaction is handled by the union type ;;; method. +#+nil (define-type-method (member :simple-union) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) @@ -2958,6 +2959,16 @@ (t (make-member-type :members (union mem1 mem2)))))) +(define-type-method (member :simple-union) (type1 type2) + (let ((mem1 (member-type-members type1)) + (mem2 (member-type-members type2))) + (cond ((subsetp mem1 mem2) type2) + ((subsetp mem2 mem1) type1) + ;; NEW: refuse to merge across character/non-character domains + ((and (some #'characterp mem1) (notevery #'characterp mem2)) nil) + ((and (some #'characterp mem2) (notevery #'characterp mem1)) nil) + (t (make-member-type :members (union mem1 mem2)))))) + (define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e7c711a7ef9ccad3cfdbf5a3... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e7c711a7ef9ccad3cfdbf5a3... 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