From 807d6f0f10baa4f1d80c0d698bdd10a9b7b1fe2c Mon Sep 17 00:00:00 2001
From: emarsden <emarsden>
Date: Mon, 12 May 2003 16:30:42 +0000
Subject: [PATCH] Add package locks. Bootfile boot8.lisp allows this to build
 without a cross-compile (or just select the CLOBBER-IT restart).

   - two extra PACKAGE-LOCK and PACKAGE-DEFINITION-LOCK slots added to
     the package structure. These can be modified using the
     EXT:PACKAGE-LOCK and EXT:PACKAGE-DEFINITION-LOCK accessors.

   - macro EXT:WITHOUT-PACKAGE-LOCKS that evaluates forms with all
     package locks disabled (this is done by binding the global
     variable CL::*ENABLE-PACKAGE-LOCKED-ERRORS*)

   - new PACKAGE-LOCKED-ERROR condition

   - in SETF-FDEFINITION-HOOK and in the DEFMACRO, DEFSTRUCT, DEFTYPE
     and DEFCLASS defining forms, check whether the definition would
     modify a package whose definition-lock is enabled, and signal a
     package-locked-error condition with restarts that allow you to
     unlock the package or ignore the lock

   - in EXPORT, UNEXPORT etc check whether the target package is
     guarded by a package-lock, and signal an error

   - disable package locks when loading a subsystem

   - disable package locks in certain areas of PCL and in the
     MAKE-LOAD-FORM support of the compiler, where code is generated
     inside system packages at runtime
---
 bootfiles/18e/boot8.lisp |  41 ++++++++
 code/defstruct.lisp      |  16 ++-
 code/exports.lisp        |   9 +-
 code/macros.lisp         |  36 ++++++-
 code/module.lisp         |   5 +-
 code/package.lisp        | 206 +++++++++++++++++++++++++++++++--------
 compiler/main.lisp       |  22 +++--
 pcl/braid.lisp           |  19 ++--
 pcl/cache.lisp           |   8 +-
 pcl/ctor.lisp            |  17 ++--
 pcl/defclass.lisp        |   5 +-
 pcl/low.lisp             |  31 +++---
 12 files changed, 317 insertions(+), 98 deletions(-)
 create mode 100644 bootfiles/18e/boot8.lisp

diff --git a/bootfiles/18e/boot8.lisp b/bootfiles/18e/boot8.lisp
new file mode 100644
index 000000000..92980c5a5
--- /dev/null
+++ b/bootfiles/18e/boot8.lisp
@@ -0,0 +1,41 @@
+;;;
+;;; Bootfile for adding package locks.
+;;; Use this file as bootstrap.lisp using Pierre Mai's build scripts,
+;;;
+
+(in-package :lisp)
+
+(defvar *enable-package-locked-errors* nil)
+
+;;;
+;;; Like DEFSTRUCT, but silently clobber old definitions.
+;;;
+(defmacro defstruct! (name &rest stuff)
+  `(handler-bind ((error (lambda (c)
+			   (declare (ignore c))
+			   (invoke-restart 'kernel::clobber-it))))
+     (defstruct ,name ,@stuff)))
+
+
+(defstruct! (package
+	    (:constructor internal-make-package)
+	    (:predicate packagep)
+	    (:print-function %print-package)
+	    (:make-load-form-fun
+	     (lambda (package)
+	       (values `(package-or-lose ',(package-name package))
+		       nil))))
+  (tables (list nil))
+  (%name nil :type (or simple-string null))
+  (%nicknames () :type list)
+  (%use-list () :type list)
+  (%used-by-list () :type list)
+  (internal-symbols (required-argument) :type package-hashtable)
+  (external-symbols (required-argument) :type package-hashtable)
+  (%shadowing-symbols () :type list)
+  (lock nil :type boolean)
+  (definition-lock nil :type boolean)
+  (doc-string nil :type (or simple-string null)))
+
+
+;;; end of file
diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 42432d9d2..df0c350ac 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.84 2003/03/30 18:43:59 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.85 2003/05/12 16:30:41 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -453,8 +453,20 @@
   (let* ((defstruct (parse-name-and-options
 		     (if (atom name-and-options)
 			 (list name-and-options)
-			 name-and-options))) 
+			 name-and-options)))
 	 (name (dd-name defstruct)))
+    (when cl::*enable-package-locked-errors*
+      (when (ext:package-definition-lock (symbol-package name))
+        (restart-case
+            (error 'cl::package-locked-error
+                   :package (symbol-package name)
+                   :format-control "defining structure ~A"
+                   :format-arguments (list name))
+          (continue ()
+            :report "Ignore the lock and continue")
+          (unlock-package ()
+            :report "Disable package's lock then continue"
+            (setf (ext:package-lock (symbol-package name)) nil)))))
     (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 e5253d80a..750ba0612 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.206 2003/04/19 20:52:43 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.207 2003/05/12 16:30:41 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,7 +17,9 @@
 (if (find-package "PCL")
     (rename-package "PCL" "PCL" 'nil)
     (make-package "PCL" :nicknames 'nil :use nil))
-
+(if (find-package "CLOS-MOP")
+    (rename-package "CLOS-MOP" "CLOS-MOP" 'nil)
+    (make-package "CLOS-MOP" :nicknames 'nil :use nil))
 (if (find-package "C-CALL")
     (rename-package "C-CALL" "C-CALL" 'nil)
     (make-package "C-CALL" :nicknames 'nil :use nil))
@@ -187,7 +189,9 @@
             (:export "CADDR-T" "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN"
              "DADDR-T" "DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
              "F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
+             "FSFILCNT-T" "FSBLKCNT-T" "BLKCNT-T"
              "FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
+             "F_TEST" "F_TLOCK" "UNIX-LOCKF" "F_LOCK" "F_ULOCK"
              "F_OK" "GET-UNIX-ERROR-MSG" "GID-T" "INO-T" "IT-INTERVAL"
              "IT-VALUE" "ITIMERVAL" "UNIX-SETITIMER" "UNIX-GETITIMER"
 	     "BLKCNT-T" "FSBLKCNT-T" "FSFILCNT-T"
@@ -990,6 +994,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"
              "PRINT-DIRECTORY" "PRINT-HERALD" "PRINT-PRETTY-KEY"
              "PRINT-PRETTY-KEY-EVENT" "PROCESS-ALIVE-P" "PROCESS-CLOSE"
              "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE"
diff --git a/code/macros.lisp b/code/macros.lisp
index 343f15b53..9760e7dd0 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.92 2003/04/19 20:52:43 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.93 2003/05/12 16:30:41 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -75,6 +75,23 @@
 ;;; definition is done by %defmacro which we expand into.
 ;;;
 (defmacro defmacro (name lambda-list &body body)
+  (when cl::*enable-package-locked-errors*
+    (multiple-value-bind (valid block-name)
+        (ext:valid-function-name-p name)
+      (declare (ignore valid))
+      (let ((package (symbol-package block-name)))
+        (when package
+          (when (ext:package-definition-lock package)
+            (restart-case
+                (error 'cl::package-locked-error
+                       :package package
+                       :format-control "defining macro ~A"
+                       :format-arguments (list name))
+              (continue ()
+                :report "Ignore the lock and continue")
+              (unlock-package ()
+                :report "Disable the package's definition-lock then continue"
+                (setf (ext:package-definition-lock package) nil))))))))
   (let ((whole (gensym "WHOLE-"))
 	(environment (gensym "ENV-")))
     (multiple-value-bind
@@ -105,8 +122,7 @@
 ;;;
 (defun c::%defmacro (name definition lambda-list doc)
   (assert (eval:interpreted-function-p definition))
-  (setf (eval:interpreted-function-name definition)
-	(format nil "DEFMACRO ~S" name))
+  (setf (eval:interpreted-function-name definition) name)
   (setf (eval:interpreted-function-arglist definition) lambda-list)
   (c::%%defmacro name definition doc))
 ;;;
@@ -188,7 +204,19 @@
   "Syntax like DEFMACRO, but defines a new type."
   (unless (symbolp name)
     (simple-program-error "~S -- Type name not a symbol." name))
-  
+  (and cl::*enable-package-locked-errors*
+       (symbol-package name)
+       (ext:package-definition-lock (symbol-package name))
+       (restart-case
+           (error 'cl::package-locked-error
+                  :package (symbol-package name)
+                  :format-control "defining type ~A"
+                  :format-arguments (list name))
+         (continue ()
+           :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))))
   (let ((whole (gensym "WHOLE-")))
     (multiple-value-bind (body local-decs doc)
 			 (parse-defmacro arglist whole body name 'deftype
diff --git a/code/module.lisp b/code/module.lisp
index 00118dd0b..0ca540809 100644
--- a/code/module.lisp
+++ b/code/module.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/module.lisp,v 1.7 2001/12/11 00:44:23 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/module.lisp,v 1.8 2003/05/12 16:30:41 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 
@@ -83,7 +83,8 @@
 		    (list (module-default-pathname module-name))))
 	 (*load-verbose* *require-verbose*))
      (dolist (file files t)
-       (load file)))))
+       (ext:without-package-locks
+        (load file))))))
 
 
 
diff --git a/code/package.lisp b/code/package.lisp
index b50a8cf28..b364794ef 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.65 2003/05/09 14:15:55 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.66 2003/05/12 16:30:41 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -27,7 +27,8 @@
 
 (in-package "EXTENSIONS")
 (export '(*keyword-package* *lisp-package* *default-package-use-list*
-	  map-apropos package-children package-parent))
+	  map-apropos package-children package-parent
+          package-lock package-definition-lock without-package-locks))
 
 (in-package "KERNEL")
 (export '(%in-package old-in-package %defpackage))
@@ -75,6 +76,15 @@
   ;; List of shadowing symbols.
   (%shadowing-symbols () :type list)
   ;;
+  ;; Locks for this package. The PACKAGE-LOCK is a lock on the
+  ;; structure of the package, and controls modifications to its list
+  ;; of symbols and its export list. The PACKAGE-DEFINITION-LOCK
+  ;; protects all symbols in the package from being redefined. These
+  ;; are initially disabled, and are enabled by the function
+  ;; PACKAGE-LOCKS-INIT during after-save-initializations. 
+  (lock nil :type boolean)
+  (definition-lock nil :type boolean)
+
   ;; Documentation string for this package
   (doc-string nil :type (or simple-string null)))
 
@@ -82,11 +92,15 @@
 (defun %print-package (s stream d)
   (declare (ignore d) (stream stream))
   (if (package-%name s)
-      (multiple-value-bind (iu it) (internal-symbol-count s)
-	(multiple-value-bind (eu et) (external-symbol-count s)
-	  (print-unreadable-object (s stream)
-	    (format stream "The ~A package, ~D/~D internal, ~D/~D external"
-		    (package-%name s) iu it eu et))))
+      (cond (*print-escape*
+             (multiple-value-bind (iu it) (internal-symbol-count s)
+               (multiple-value-bind (eu et) (external-symbol-count s)
+                 (print-unreadable-object (s stream)
+                   (format stream "The ~A package, ~D/~D internal, ~D/~D external"
+                           (package-%name s) iu it eu et)))))
+            (t
+             (print-unreadable-object (s stream)
+               (format stream "The ~A package" (package-%name s)))))
       (print-unreadable-object (s stream :identity t)
 	(format stream "deleted package"))))
 
@@ -116,6 +130,74 @@
 (defvar *keyword-package*)
 
 
+(defvar *enable-package-locked-errors* nil)
+
+
+(define-condition package-locked-error (simple-package-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "~&~@<Attempt to modify the locked package ~A, by ~3i~:_~?~:>"
+                     (package-name (package-error-package condition))
+                     (simple-condition-format-control condition)
+                     (simple-condition-format-arguments condition)))))
+
+(defun package-locks-init ()
+  (let ((package-names '("COMMON-LISP" "PCL" "CLOS-MOP" "EVAL"
+                         "NEW-ASSEM" "DISASSEM" "LOOP" "ANSI-LOOP" "INSPECT"
+                         "C" "PROFILE" "WIRE" "BIGNUM" "VM"
+                         "FORMAT" "DFIXNUM" "PRETTY-PRINT" "C-CALL" "ALIEN"
+                         "ALIEN-INTERNALS" "UNIX"
+                         "CONDITIONS" "DEBUG" "DEBUG-INTERNALS" "SYSTEM"
+                         "KERNEL" "EXTENSIONS" #+mp "MULTIPROCESSING"
+                         "WALKER" "XREF")))
+    (dolist (p package-names)
+      (let ((p (find-package p)))
+        (when p
+          (setf (package-definition-lock p) t)
+          (setf (package-lock p) t))))
+    (setf *enable-package-locked-errors* t)
+    (push 'redefining-function ext:*setf-fdefinition-hook*))
+  (values))
+
+(pushnew 'package-locks-init ext:*after-save-initializations*)
+
+
+(defmacro without-package-locks (&body body)
+  `(let ((*enable-package-locked-errors* nil))
+      ,@body))
+
+
+;; trap attempts to redefine a function in a locked package, and
+;; signal a continuable error.
+(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 "redefining function ~A"
+                       :format-arguments (list function))
+              (continue ()
+                :report "Ignore the lock and continue")
+              (unlock-package ()
+                :report "Disable package's definition-lock then continue"
+                (setf (ext:package-definition-lock package) nil)))))))))
+
+
 ;;; This magical variable is T during initialization so Use-Package's of packages
 ;;; that don't yet exist quietly win.  Such packages are thrown onto the list
 ;;; *Deferred-Use-Packages* so that this can be fixed up later.
@@ -173,7 +255,7 @@
 ;;;
 #+relative-package-names
 (defun package-parent (package-specifier)
-  "Given package-specifier, a package, symbol or string, return the
+  "Given PACKAGE-SPECIFIER, a package, symbol or string, return the
   parent package.  If there is not a parent, signal an error."
   (declare (optimize (speed 3)))
   (flet ((find-last-dot (name)
@@ -205,7 +287,7 @@
 ;;;
 #+relative-package-names
 (defun package-children (package-specifier &key (recurse t))
-  "Given package-specifier, a package, symbol or string, return all the
+  "Given PACKAGE-SPECIFIER, a package, symbol or string, return all the
   packages which are in the hierarchy 'under' the given package.  If
   :recurse is nil, then only return the immediate children of the package."
   (declare (optimize (speed 3)))
@@ -893,7 +975,7 @@
 		    ',imports ',interns ',exports ',doc))))
 
 (defun check-disjoint (&rest args)
-  ;; Check wether all given arguments specify disjoint sets of symbols.
+  ;; Check whether all given arguments specify disjoint sets of symbols.
   ;; Each argument is of the form (:key . set).
   (loop for (current-arg . rest-args) on args
         do
@@ -950,7 +1032,7 @@
 	(let ((laterize (set-difference old-use-list new-use-list)))
 	  (when laterize
 	    (unuse-package laterize package)
-	    (warn "~A used to use the following packages:~%  ~S"
+	    (warn "~A previously used the following packages:~%  ~S"
 		  name
 		  laterize)))))
     ;; Import and Intern.
@@ -1055,9 +1137,9 @@
 ;;;    Like Make-Package, only different.  Should go away someday.
 ;;;
 (defun old-in-package (name &rest keys &key nicknames use)
-  "Sets *package* to package with given name, creating the package if
+  "Sets *PACKAGE* to package with given NAME, creating the package if
    it does not exist.  If the package already exists then it is modified
-   to agree with the :Use and :Nicknames arguments.  Any new nicknames
+   to agree with the :USE and :NICKNAMES arguments.  Any new nicknames
    are added without removing any old ones not specified.  If any package
    in the :Use list is not currently used, then it is added to the use
    list."
@@ -1120,7 +1202,7 @@
 ;;; Delete-Package -- Public
 ;;;
 (defun delete-package (package-or-name)
-  "Delete the package-or-name from the package system data structures."
+  "Delete the PACKAGE-OR-NAME from the package system data structures."
   (let ((package (if (packagep package-or-name)
 		     package-or-name
 		     (find-package package-or-name))))
@@ -1174,17 +1256,17 @@
 ;;;
 (defun intern (name &optional package)
   "Returns a symbol having the specified name, creating it if necessary."
-  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
-    (declare (simple-string name))
-    (intern* name (length name)
-	     (if package (package-or-lose package) *package*))))
+  (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))
+        (package (if package (package-or-lose package) *package*)))
+    (declare (type simple-string name))
+    (intern* name (length name) package)))
 
 ;;; Find-Symbol  --  Public
 ;;;
 ;;;    Ditto.
 ;;;
 (defun find-symbol (name &optional package)
-  "Returns the symbol named String in Package.  If such a symbol is found
+  "Returns the symbol NAME in PACKAGE.  If such a symbol is found
   then the second value is :internal, :external or :inherited to indicate
   how the symbol is accessible.  If no symbol is found then both values
   are NIL."
@@ -1203,14 +1285,28 @@
   (multiple-value-bind (symbol where) (find-symbol* name length package)
     (if where
 	(values symbol where)
-	(let ((symbol (make-symbol (subseq name 0 length))))
-	  (%set-symbol-package symbol package)
-	  (cond ((eq package *keyword-package*)
-		 (add-symbol (package-external-symbols package) symbol)
-		 (%set-symbol-value symbol symbol))
-		(t
-		 (add-symbol (package-internal-symbols package) symbol)))
-	  (values symbol nil)))))
+        (progn
+          #+nil
+          (when *enable-package-locked-errors*
+            (when (ext:package-lock package)
+              (restart-case
+                  (error 'package-locked-error
+                         :package package
+                         :format-control "interning symbol ~A"
+                         :format-arguments (list (subseq name 0 length)))
+                (continue ()
+                  :report "Ignore the lock and continue")
+                (unlock-package ()
+                  :report "Unlock package then continue"
+                  (setf (ext:package-lock package) nil)))))
+          (let ((symbol (make-symbol (subseq name 0 length))))
+            (%set-symbol-package symbol package)
+            (cond ((eq package *keyword-package*)
+                   (add-symbol (package-external-symbols package) symbol)
+                   (%set-symbol-value symbol symbol))
+                  (t
+                   (add-symbol (package-internal-symbols package) symbol)))
+            (values symbol nil))))))
 
 ;;; find-symbol*  --  Internal
 ;;;
@@ -1264,13 +1360,25 @@
 ;;; result, otherwise just nuke the symbol.
 ;;;
 (defun unintern (symbol &optional (package *package*))
-  "Makes Symbol no longer present in Package.  If Symbol was present
-  then T is returned, otherwise NIL.  If Package is Symbol's home
+  "Makes SYMBOL no longer present in PACKAGE.  If SYMBOL was present
+  then T is returned, otherwise NIL.  If PACKAGE is SYMBOL's home
   package, then it is made uninterned."
   (let* ((package (package-or-lose package))
 	 (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 "uninterning symbol ~A"
+                   :format-arguments (list name))
+          (continue ()
+            :report "Ignore the lock and continue")
+          (unlock-package ()
+            :report "Disable package's lock then continue"
+            (setf (ext:package-lock package) nil)))))
     ;;
     ;; If a name conflict is revealed, give use a chance to shadowing-import
     ;; one of the accessible symbols.
@@ -1350,7 +1458,7 @@
 ;;;    Do more stuff.
 ;;;
 (defun export (symbols &optional (package *package*))
-  "Exports Symbols from Package, checking that no name conflicts result."
+  "Exports SYMBOLS from PACKAGE, checking that no name conflicts result."
   (let ((package (package-or-lose package))
 	(syms ()))
     ;;
@@ -1427,9 +1535,21 @@
 ;;; internal.
 ;;;
 (defun unexport (symbols &optional (package *package*))
-  "Makes Symbols no longer exported from Package."
+  "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 "unexporting symbols ~A"
+                   :format-arguments (list symbols))
+          (continue ()
+            :report "Ignore the lock and continue")
+          (unlock-package ()
+            :report "Disable package's lock then continue"
+            (setf (ext:package-lock package) nil)))))
     (dolist (sym (symbol-listify symbols))
       (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
 	(cond ((or (not w) (not (eq s sym)))
@@ -1452,7 +1572,7 @@
 ;;; shadowing-import if there is.
 ;;;
 (defun import (symbols &optional (package *package*))
-  "Make Symbols accessible as internal symbols in Package.  If a symbol
+  "Make SYMBOLS accessible as internal symbols in PACKAGE.  If a symbol
   is already accessible then it has no effect.  If a name conflict
   would result from the importation, then a correctable error is signalled."
   (let ((package (package-or-lose package))
@@ -1495,7 +1615,7 @@
 ;;; stick the symbol in.
 ;;;
 (defun shadowing-import (symbols &optional (package *package*))
-  "Import Symbols into package, disregarding any name conflict.  If
+  "Import SYMBOLS into PACKAGE, disregarding any name conflict.  If
   a symbol of the same name is present, then it is uninterned.
   The symbols are added to the Package-Shadowing-Symbols."
   (let* ((package (package-or-lose package))
@@ -1518,9 +1638,9 @@
 ;;;
 ;;;
 (defun shadow (symbols &optional (package *package*))
-  "Make an internal symbol in Package with the same name as each of the
-  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
-  If a symbol with the given name is already present in Package, then
+  "Make an internal symbol in PACKAGE with the same name as each of the
+  specified SYMBOLS, adding the new symbols to the Package-Shadowing-Symbols.
+  If a symbol with the given name is already present in PACKAGE, then
   the existing symbol is placed in the shadowing symbols list if it is
   not already present."
   (let* ((package (package-or-lose package))
@@ -1543,9 +1663,9 @@
 ;;; checking.
 ;;;
 (defun use-package (packages-to-use &optional (package *package*))
-  "Add all the Package-To-Use to the use list for Package so that
+  "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that
   the external symbols of the used packages are accessible as internal
-  symbols in Package."
+  symbols in PACKAGE."
   (let ((packages (package-listify packages-to-use))
 	(package (package-or-lose package)))
     ;;
@@ -1607,7 +1727,7 @@
 ;;;
 ;;;
 (defun unuse-package (packages-to-unuse &optional (package *package*))
-  "Remove Packages-To-Unuse from the use list for Package."
+  "Remove PACKAGES-TO-UNUSE from the use list for PACKAGE."
   (let ((package (package-or-lose package)))
     (dolist (p (package-listify packages-to-unuse))
       (setf (package-%use-list package)
@@ -1746,9 +1866,9 @@
 ;;; APROPOS -- public.
 ;;; 
 (defun apropos (string &optional package external-only)
-  "Briefly describe all symbols which contain the specified String.
-  If Package is supplied then only describe symbols present in
-  that package.  If External-Only is true then only describe
+  "Briefly describe all symbols which contain the specified STRING.
+  If PACKAGE is supplied then only describe symbols present in
+  that package.  If EXTERNAL-ONLY is non-NIL then only describe
   external symbols in the specified package."
   (map-apropos #'briefly-describe-symbol string package external-only)
   (values))
@@ -1756,7 +1876,7 @@
 ;;; APROPOS-LIST -- public.
 ;;; 
 (defun apropos-list (string &optional package external-only)
-  "Identical to Apropos, except that it returns a list of the symbols
+  "Identical to APROPOS, except that it returns a list of the symbols
   found instead of describing them."
   (collect ((result))
     (map-apropos #'(lambda (symbol)
diff --git a/compiler/main.lisp b/compiler/main.lisp
index 0f14f093c..5cbb82013 100644
--- a/compiler/main.lisp
+++ b/compiler/main.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/compiler/main.lisp,v 1.134 2003/04/11 14:24:22 emarsden Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.135 2003/05/12 16:30:42 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1189,7 +1189,8 @@
    (let* ((*lexical-environment* (make-null-environment))
 	  (lambda (ir1-top-level form *current-path* for-value)))
      (setf (leaf-name lambda) name)
-     (compile-top-level (list lambda) t)
+     (ext:without-package-locks
+      (compile-top-level (list lambda) t))
      lambda)))
 
 ;;; COMPILE-LOAD-TIME-VALUE-LAMBDA  --  internal.
@@ -1269,13 +1270,15 @@
 	(creation-form init-form)
 	(handler-case
 	    (if (fboundp 'lisp::make-load-form)
-		(locally
-		 (declare (optimize (inhibit-warnings 3)))
-		 (lisp::make-load-form constant (make-null-environment)))
-		(make-structure-load-form constant))
+                (locally
+                    (declare (optimize (inhibit-warnings 3)))
+                  (ext:without-package-locks
+                   (lisp::make-load-form constant (make-null-environment))))
+                (ext:without-package-locks
+                 (make-structure-load-form constant)))
 	  (error (condition)
-		 (compiler-error "(while making load form for ~S)~%~A"
-				 constant condition)))
+            (compiler-error "(while making load form for ~S)~%~A"
+                            constant condition)))
       (case creation-form
 	(:just-dump-it-normally
 	 (fasl-validate-structure constant *compile-object*)
@@ -1806,7 +1809,8 @@
 		;; Hack around filesystem race condition...
 		(or (probe-file output-file-pathname) output-file-pathname)
 		nil)
-	    (not (null error-severity))
+            (if (member error-severity '(:warning :error)) t nil)
+            ;; FIXME in the following we should not return t for a STYLE-WARNING
 	    (if (member error-severity '(:warning :error)) t nil))))
 
 ;;;; COMPILE and UNCOMPILE:
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index f52825c8d..590205abb 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.37 2003/05/11 11:30:35 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.38 2003/05/12 16:30:42 emarsden Exp $")
 
 ;;;
 ;;; Bootstrapping the meta-braid.
@@ -518,14 +518,15 @@
 	   (let* ((class (kernel::find-class name))
 		  (kernel-supers (kernel:%class-direct-superclasses class))
 		  (supers (mapcar #'kernel:%class-name kernel-supers)))
-	     (if slotsp
-		 (ensure-class-using-class
-		  existing-class name :metaclass metaclass :name name
-		  :direct-superclasses supers
-		  :direct-slots slots)
-		 (ensure-class-using-class
-		  existing-class name :metaclass metaclass :name name
-		  :direct-superclasses supers))))
+             (ext:without-package-locks
+              (if slotsp
+                  (ensure-class-using-class
+                   existing-class name :metaclass metaclass :name name
+                   :direct-superclasses supers
+                   :direct-slots slots)
+                  (ensure-class-using-class
+                   existing-class name :metaclass metaclass :name name
+                   :direct-superclasses supers)))))
 	 (slot-initargs-from-structure-slotd (slotd)
 	   (let ((accessor (structure-slotd-accessor-symbol slotd)))
 	     `(:name ,(structure-slotd-name slotd)
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index f18239107..95dac9346 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.29 2003/05/04 13:11:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.30 2003/05/12 16:30:42 emarsden Exp $")
 
 ;;;
 ;;; The basics of the PCL wrapper cache mechanism.
@@ -725,7 +725,8 @@
 
 (defun dfun-arg-symbol (arg-number)
   (or (nth arg-number (the list *dfun-arg-symbols*))
-      (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))
+      (ext:without-package-locks
+       (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))))
 
 (defun dfun-arg-symbol-list (metatypes)
   (loop for i from 0 and s in metatypes
@@ -735,7 +736,8 @@
 
 (defun slot-vector-symbol (arg-number)
   (or (nth arg-number (the list *slot-vector-symbols*))
-      (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))
+      (ext:without-package-locks
+       (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))))
 
 (defun make-dfun-lambda-list (metatypes applyp)
   (if applyp
diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp
index 7c07aae84..e95c27506 100644
--- a/pcl/ctor.lisp
+++ b/pcl/ctor.lisp
@@ -46,7 +46,7 @@
 ;;; is called.
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.8 2003/05/04 13:11:22 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.9 2003/05/12 16:30:42 emarsden Exp $")
 
 (in-package "PCL")
 
@@ -175,7 +175,8 @@
 	       (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.)))
 		 (if (array-in-bounds-p ps i)
 		     (aref ps i)
-		     (intern (format nil ".P~D." i) *the-pcl-package*))))
+                     (ext:without-package-locks
+                      (intern (format nil ".P~D." i) *the-pcl-package*)))))
 	     ;;
 	     ;; Check if CLASS-NAME is a constant symbol.  Give up if
 	     ;; not.
@@ -220,10 +221,11 @@
 	  ;; Return code constructing a ctor at load time, which, when
 	  ;; called, will set its funcallable instance function to an
 	  ;; optimized constructor function.
-	  `(let ((.x. (load-time-value
-		       (ensure-ctor ',function-name ',class-name ',initargs))))
-	     (declare (ignore .x.))
-	     (funcall (function ,function-name) ,@value-forms)))))))
+	  `(ext:without-package-locks
+            (let ((.x. (load-time-value
+                        (ensure-ctor ',function-name ',class-name ',initargs))))
+              (declare (ignore .x.))
+              (funcall (function ,function-name) ,@value-forms))))))))
 
 
 ;;; **************************************************
@@ -493,7 +495,8 @@
 	       (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
 		 (if (array-in-bounds-p ps i)
 		     (aref ps i)
-		     (intern (format nil ".D~D." i) *the-pcl-package*)))))
+                     (ext:without-package-locks
+                      (intern (format nil ".D~D." i) *the-pcl-package*))))))
       ;;
       ;; Loop over supplied initargs and values and record which
       ;; instance and class slots they initialize.
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index fda35f639..358e0979e 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.27 2003/05/04 13:11:22 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.28 2003/05/12 16:30:42 emarsden Exp $")
 ;;;
 
 (in-package :pcl)
@@ -73,7 +73,8 @@
 ;;; 
 (defmacro defclass (name direct-superclasses direct-slots
 		    &rest options &environment env)
-  (expand-defclass name direct-superclasses direct-slots options env))
+  (ext:without-package-locks
+   (expand-defclass name direct-superclasses direct-slots options env)))
 
 ;;; The following functions were moved here from slots-boot.lisp
 ;;; because expand-defclass now depends on them to generate ftype
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 2725ba853..c872f5080 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.26 2003/05/07 17:15:48 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.27 2003/05/12 16:30:42 emarsden Exp $")
 
 ;;; 
 ;;; This file contains optimized low-level constructs for PCL.
@@ -106,23 +106,24 @@
   (declare (special *boot-state* *the-class-standard-generic-function*))
   (when (valid-function-name-p function)
     (setq function (fdefinition function)))
-  (when (funcallable-instance-p function)
-    (if (if (eq *boot-state* 'complete)
-	    (typep function 'generic-function)
-	    (eq (class-of function) *the-class-standard-generic-function*))
-	(setf (kernel:%funcallable-instance-info function 1) new-name)
-	(typecase function
-	  (kernel:byte-closure
-	   (set-function-name (kernel:byte-closure-function function)
-			      new-name))
-	  (kernel:byte-function
-	   (setf (kernel:byte-function-name function) new-name))
-	  (eval:interpreted-function
-	   (setf (eval:interpreted-function-name function) new-name)))))
+  (ext:without-package-locks
+   (when (funcallable-instance-p function)
+     (if (if (eq *boot-state* 'complete)
+             (typep function 'generic-function)
+             (eq (class-of function) *the-class-standard-generic-function*))
+         (setf (kernel:%funcallable-instance-info function 1) new-name)
+         (typecase function
+           (kernel:byte-closure
+            (set-function-name (kernel:byte-closure-function function)
+                               new-name))
+           (kernel:byte-function
+            (setf (kernel:byte-function-name function) new-name))
+           (eval:interpreted-function
+            (setf (eval:interpreted-function-name function) new-name))))))
   (when (memq (car-safe new-name) '(method fast-method slot-accessor))
     (setf (fdefinition new-name) function))
   function)
-	
+
 (defun symbolicate* (pkg &rest things)
   (let ((*package* pkg))
     (apply #'symbolicate things)))
-- 
GitLab