From 1a9602792c773fb37995036a4013a271aba1637a Mon Sep 17 00:00:00 2001 From: emarsden <emarsden> Date: Fri, 8 Aug 2003 11:32:52 +0000 Subject: [PATCH] Add a function EXT:UNLOCK-ALL-PACKAGES, that disables both the structural and the definition locks for all existing packages. Add an additional restart to the PACKAGE-LOCKED-ERROR signaling points that allows the user to disable all packages then continue. Package locks are initialized upon startup, so the unlocking only takes effect during the current session. However, this function doesn't suffer from the problem that affects LISP::*ENABLE-PACKAGE-LOCKED-ERRORS* (which is bound by LOAD so can't be set from an initialization file). --- code/defstruct.lisp | 7 +++++-- code/exports.lisp | 11 +++++++---- code/macros.lisp | 14 ++++++++++---- code/package.lisp | 35 +++++++++++++++++++++++++++-------- 4 files changed, 49 insertions(+), 18 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index e292772ca..aeb086402 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.91 2003/08/06 19:01:18 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.92 2003/08/08 11:32:52 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -461,7 +461,10 @@ :report "Ignore the lock and continue") (unlock-package () :report "Disable package's lock then continue" - (setf (ext:package-lock pkg) nil)))) + (setf (ext:package-lock pkg) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (lisp::unlock-all-packages)))) (when (stringp (car slot-descriptions)) (setf (dd-doc defstruct) (pop slot-descriptions))) (dolist (slot slot-descriptions) diff --git a/code/exports.lisp b/code/exports.lisp index cc9765560..38ac5bd07 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.221 2003/08/06 19:00:13 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.222 2003/08/08 11:32:52 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -245,6 +245,7 @@ "UNIX-RMDIR" "UNIX-SCHED-YIELD" "UNIX-SELECT" "UNIX-SEND" "UNIX-SETPGID" "UNIX-SETPGRP" "UNIX-SETREGID" "UNIX-SETREUID" "UNIX-SETSOCKOPT" "UNIX-SOCKET" + "UNIX-SETUID" "UNIX-SETGID" "UNIX-STAT" "UNIX-SYMLINK" "UNIX-SYNC" "UNIX-TIMES" "UNIX-TRUNCATE" "UNIX-TTYNAME" "UNIX-UID" "UNIX-UNAME" "UNIX-UNLINK" "UNIX-UTIMES" "UNIX-WRITE" "WINSIZE" @@ -1223,7 +1224,7 @@ "OBJECT-SET-EVENT-HANDLER" "OLD-TRACE" "OLD-UNTRACE" "ONCE-ONLY" "OPEN-CLX-DISPLAY" "OPTIMIZE-INTERFACE" "PACKAGE-CHILDREN" "PACKAGE-PARENT" "PARSE-TIME" - "PACKAGE-LOCK" "PACKAGE-DEFINITION-LOCK" "WITHOUT-PACKAGE-LOCKS" + "PACKAGE-LOCK" "PACKAGE-DEFINITION-LOCK" "WITHOUT-PACKAGE-LOCKS" "UNLOCK-ALL-PACKAGES" "PRINT-DIRECTORY" "PRINT-HERALD" "PRINT-PRETTY-KEY" "PRINT-PRETTY-KEY-EVENT" "PROCESS-ALIVE-P" "PROCESS-CLOSE" "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" @@ -1590,8 +1591,10 @@ "WHO-REFERENCES" "WHO-BINDS" "WHO-SETS" - #+pcl "WHO-SUBCLASSES" - #+pcl "WHO-SUPERCLASSES" + "WHO-SUBCLASSES" + "WHO-SUPERCLASSES" + "WHO-SPECIALIZES" + "WHO-MACROEXPANDS" "MAKE-XREF-CONTEXT" "XREF-CONTEXT-NAME" "XREF-CONTEXT-FILE" diff --git a/code/macros.lisp b/code/macros.lisp index 3a225d7b0..df041716d 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.96 2003/07/17 17:48:32 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.97 2003/08/08 11:32:52 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -91,7 +91,10 @@ :report "Ignore the lock and continue") (unlock-package () :report "Disable the package's definition-lock then continue" - (setf (ext:package-definition-lock package) nil)))))))) + (setf (ext:package-definition-lock package) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (lisp::unlock-all-packages)))))))) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind @@ -216,7 +219,10 @@ :report "Ignore the lock and continue") (unlock-package () :report "Disable package's definition-lock then continue" - (setf (ext:package-definition-lock (symbol-package name)) nil)))) + (setf (ext:package-definition-lock (symbol-package name)) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (lisp::unlock-all-packages)))) (let ((whole (gensym "WHOLE-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro arglist whole body name 'deftype @@ -1858,7 +1864,7 @@ (handler-bind ((c::parse-unknown-type #'(lambda (c) (c::note-undefined-reference - (c::parse-unknown-type-specifier c) + (kernel:parse-unknown-type-specifier c) :type)))) (unwind-protect (multiple-value-prog1 diff --git a/code/package.lisp b/code/package.lisp index e1975e1b6..92e77b86f 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.70 2003/06/18 09:23:10 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.71 2003/08/08 11:32:52 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -28,7 +28,8 @@ (in-package "EXTENSIONS") (export '(*keyword-package* *lisp-package* *default-package-use-list* map-apropos package-children package-parent - package-lock package-definition-lock without-package-locks)) + package-lock package-definition-lock without-package-locks + unlock-all-packages)) (in-package "KERNEL") (export '(%in-package old-in-package %defpackage)) @@ -162,6 +163,12 @@ (pushnew 'package-locks-init ext:*after-save-initializations*) +(defun unlock-all-packages () + (dolist (p (list-all-packages)) + (setf (package-definition-lock p) nil) + (setf (package-lock p) nil))) + + (defmacro without-package-locks (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) (let ((*enable-package-locked-errors* nil)) @@ -195,8 +202,11 @@ (continue () :report "Ignore the lock and continue") (unlock-package () - :report "Disable package's definition-lock then continue" - (setf (ext:package-definition-lock package) nil))))))))) + :report "Disable package's definition-lock, then continue" + (setf (ext:package-definition-lock package) nil)) + (unlock-all () + :report "Disable all package locks, then continue" + (unlock-all-packages))))))))) ;;; This magical variable is T during initialization so Use-Package's of packages @@ -1299,8 +1309,11 @@ (continue () :report "Ignore the lock and continue") (unlock-package () - :report "Unlock package then continue" - (setf (ext:package-lock package) nil))))) + :report "Unlock package, then continue" + (setf (ext:package-lock package) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (unlock-all-packages))))) (let ((symbol (make-symbol (subseq name 0 length)))) (%set-symbol-package symbol package) (cond ((eq package *keyword-package*) @@ -1380,7 +1393,10 @@ :report "Ignore the lock and continue") (unlock-package () :report "Disable package's lock then continue" - (setf (ext:package-lock package) nil))))) + (setf (ext:package-lock package) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (unlock-all-packages))))) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. @@ -1551,7 +1567,10 @@ :report "Ignore the lock and continue") (unlock-package () :report "Disable package's lock then continue" - (setf (ext:package-lock package) nil))))) + (setf (ext:package-lock package) nil)) + (unlock-all () + :report "Unlock all packages, then continue" + (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))) -- GitLab