From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 30 Dec 2011 12:54:52 +0000 (+0200)
Subject: package locks and compile-time effects of DEFCLASS
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=737f1f34bd33a1f7080a04786479035d366e672f;p=sbcl.git

package locks and compile-time effects of DEFCLASS

  DEFCLASS FTYPE used to break SBCL, but package locks didn't catch it.
---

diff --git a/NEWS b/NEWS
index b9cffdf..e4ae3e1 100644
--- a/NEWS
+++ b/NEWS
@@ -89,6 +89,8 @@ changes relative to sbcl-1.0.54:
     subtypes of CHARACTER that are forbidden according to ANSI. (lp#841312)
   * bug fix: missing failure-to-stack-allocate compiler notes for some
     forms of MAKE-ARRAY with dynamic-extent. (lp#902351)
+  * bug fix: some of the compile-time side-effects of DEFCLASS were not caught
+    by package locks.
 
 changes in sbcl-1.0.54 relative to sbcl-1.0.53:
   * minor incompatible changes:
diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index cd9bd18..e342b6e 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -298,6 +298,7 @@
   ;; actual type as a compile-time side-effect would probably be a bad
   ;; idea and (2) anyway we don't need to modify it in order to make
   ;; NAME be recognized as a valid type name)
+  (with-single-package-locked-error (:symbol name "proclaiming ~S as a class"))
   (unless (info :type :kind name)
     ;; Tell the compiler to expect a class with the given NAME, by
     ;; writing a kind of minimal placeholder type information. This
@@ -311,11 +312,12 @@
            ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should
            ;; probably be factored into a common function -- eg.
            ;; (%proclaim-ftype name declared-or-defined).
-           (when (eq (info :function :where-from name) :assumed)
-             (proclaim-as-fun-name name)
-             (note-name-defined name :function)
-             (setf (info :function :where-from name) :defined
-                   (info :function :type name) type))))
+           (with-single-package-locked-error (:symbol name "proclaiming ~S as a function")
+             (when (eq (info :function :where-from name) :assumed)
+               (proclaim-as-fun-name name)
+               (note-name-defined name :function)
+               (setf (info :function :where-from name) :defined
+                     (info :function :type name) type)))))
     (let ((rtype (specifier-type '(function (t) t)))
           (wtype (specifier-type '(function (t t) t))))
       (dolist (reader readers)
diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp
index 3ba97a1..485f0ea 100644
--- a/tests/package-locks.impure.lisp
+++ b/tests/package-locks.impure.lisp
@@ -550,4 +550,21 @@
     (assert (equal inline-lambda
                    (function-lambda-expression #'fill-pointer)))))
 
+(with-test (:name :compile-time-defclass-package-locked)
+  ;; Compiling (DEFCLASS FTYPE ...) used to break SBCL, but the package
+  ;; locks didn't kick in till later.
+  (assert (eq :ok
+              (handler-case
+                  (ctu:file-compile `((defclass ftype () ())))
+                (sb-ext:symbol-package-locked-error (e)
+                  (when (eq 'ftype (sb-ext:package-locked-error-symbol e))
+                    :ok)))))
+  ;; Check for accessor violations as well.
+  (assert (eq :ok
+              (handler-case
+                  (ctu:file-compile `((defclass foo () ((ftype :reader ftype)))))
+                (sb-ext:symbol-package-locked-error (e)
+                  (when (eq 'ftype (sb-ext:package-locked-error-symbol e))
+                    :ok))))))
+
 ;;; WOOT! Done.