X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackage-locks.impure.lisp;h=485f0eab65c2ffd29ef7997bb8fdc6b43836e673;hb=cf49f2d086069a9c1b57f501df9a6a0bd3a34c3c;hp=536dab42cf498ede28aac7465e9cc8667e8e4ab1;hpb=e5b4fe643472dff0ea751fd7ac55fcba0fd0f4f9;p=sbcl.git

diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp
index 536dab4..485f0ea 100644
--- a/tests/package-locks.impure.lisp
+++ b/tests/package-locks.impure.lisp
@@ -519,20 +519,52 @@
      :original))
  :load t)
 
-(ctu:file-compile
- `((in-package :macro-killing-macro-2)
-   (defmacro to-die-for ()
-     :replacement)))
-
 (with-test (:name :defmacro-killing-macro)
+  (ignore-errors
+    (ctu:file-compile
+     `((in-package :macro-killing-macro-2)
+       (defmacro to-die-for ()
+         :replacement))))
   (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
 
-(ctu:file-compile
- `((in-package :macro-killing-macro-2)
-   (eval-when (:compile-toplevel)
-     (setf (macro-function 'to-die-for) (constantly :replacement2)))))
-
 (with-test (:name :setf-macro-function-killing-macro)
+  (ignore-errors
+    (ctu:file-compile
+     `((in-package :macro-killing-macro-2)
+       (eval-when (:compile-toplevel)
+         (setf (macro-function 'to-die-for) (constantly :replacement2))))))
   (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
 
+(with-test (:name :compile-time-defun-package-locked)
+  ;; Make sure compile-time side-effects of DEFUN are protected against.
+  (let ((inline-lambda (function-lambda-expression #'fill-pointer)))
+    ;; Make sure it's actually inlined...
+    (assert inline-lambda)
+    (assert (eq :ok
+                (handler-case
+                    (ctu:file-compile `((defun fill-pointer (x) x)))
+                  (sb-ext:symbol-package-locked-error (e)
+                    (when (eq 'fill-pointer
+                              (sb-ext:package-locked-error-symbol e))
+                      :ok)))))
+    (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.