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