X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-package.lisp;h=fb2e1d273d4e7ae27baeebb96630a136be19c5c4;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=a1f24bbec9b267faa02d19b5ea06b9e60689e652;hpb=e801083c864fa8f11d79be53a5d95584c960f2b3;p=sbcl.git

diff --git a/src/code/early-package.lisp b/src/code/early-package.lisp
index a1f24bb..fb2e1d2 100644
--- a/src/code/early-package.lisp
+++ b/src/code/early-package.lisp
@@ -18,13 +18,13 @@
 ;;; packages for which locks are ignored, T when locks for
 ;;; all packages are ignored, and :invalid outside package-lock
 ;;; context. FIXME: This needs to be rebound for each thread.
-(defvar *ignored-package-locks* 
+(defvar *ignored-package-locks*
   (error "*IGNORED-PACKAGE-LOCKS* should be set up in cold-init."))
 (!cold-init-forms
   (setf *ignored-package-locks* :invalid))
 
-(defmacro with-single-package-locked-error ((&optional kind thing &rest format) 
-					    &body body)
+(defmacro with-single-package-locked-error ((&optional kind thing &rest format)
+                                            &body body)
   #!-sb-package-locks (declare (ignore kind thing format))
   #!-sb-package-locks
   `(progn ,@body)
@@ -33,43 +33,45 @@
     `(progn
        (/show0 ,(first format))
        (let ((,topmost nil))
-	 ;; We use assignment and conditional restoration instead of
-	 ;; dynamic binding because we want the ignored locks
-	 ;; to propagate to the topmost context.
-	 (when (eq :invalid *ignored-package-locks*)
-	   (setf *ignored-package-locks* nil
-		 ,topmost t))
-	 (unwind-protect
-	      (progn 
-		,@(ecase kind
-		   (:symbol 
-		    `((assert-symbol-home-package-unlocked ,thing ,@format)))
-		   (:package
-		    `((assert-package-unlocked 
-		       (find-undeleted-package-or-lose ,thing) ,@format)))
-		   ((nil)
-		    `()))
-		,@body)
-	   (when ,topmost
-	     (setf *ignored-package-locks* :invalid)))))))
+         ;; We use assignment and conditional restoration instead of
+         ;; dynamic binding because we want the ignored locks
+         ;; to propagate to the topmost context.
+         (when (eq :invalid *ignored-package-locks*)
+           (setf *ignored-package-locks* nil
+                 ,topmost t))
+         (unwind-protect
+              (progn
+                ,@(ecase kind
+                   (:symbol
+                    `((assert-symbol-home-package-unlocked ,thing ,@format)))
+                   (:package
+                    `((assert-package-unlocked
+                       (find-undeleted-package-or-lose ,thing) ,@format)))
+                   ((nil)
+                    `()))
+                ,@body)
+           (when ,topmost
+             (setf *ignored-package-locks* :invalid)))))))
 
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
   #!-sb-package-locks
-  (declare (ignore symbol control))
+  (declare (ignore context symbol control))
   #!+sb-package-locks
-  (flet ((resignal (condition)
-	   ;; Signal the condition to give user defined handlers a chance,
-	   ;; if they decline convert to compiler-error.
-           (signal condition)
-           (sb!c:compiler-error condition)))
-    (handler-bind ((package-lock-violation #'resignal))
-      (with-single-package-locked-error ()
-        (assert-symbol-home-package-unlocked symbol control)))))
+  (handler-bind ((package-lock-violation
+                  (lambda (condition)
+                    (ecase context
+                      (:compile
+                       (warn "Compile-time package lock violation:~%  ~A"
+                             condition)
+                       (sb!c:compiler-error condition))
+                      (:eval
+                       (eval-error condition))))))
+    (with-single-package-locked-error (:symbol symbol control))))
 
 (defmacro without-package-locks (&body body)
   #!+sb-doc
   "Ignores all runtime package lock violations during the execution of
-body. Body can begin with declarations."  
+body. Body can begin with declarations."
   `(let (#!+sb-package-locks (*ignored-package-locks* t))
     ,@body))