+ (eval
+ '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
+ (declare (type stream test:*special*))
+ test:*special*))
+ program-error))
+
+;;; Bogus package lock violations from LOOP
+
+(assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*)
+ '(2 3)))
+
+;;; Package lock for DEFMACRO -> DEFUN and vice-versa.
+(reset-test t)
+(with-test (:name :bug-576637)
+ (assert (raises-error? (eval `(defun test:macro (x) x))
+ sb-ext:package-lock-violation))
+ (assert (eq 'test:macro (eval `(test:macro))))
+ (assert (raises-error? (eval `(defmacro test:function (x) x))
+ sb-ext:package-lock-violation))
+ (assert (eq 'test:function (eval `(test:function)))))
+
+(defpackage :macro-killing-macro-1
+ (:use :cl)
+ (:lock t)
+ (:export #:to-die-for))
+
+(defpackage :macro-killing-macro-2
+ (:use :cl :macro-killing-macro-1))
+
+(ctu:file-compile
+ `((in-package :macro-killing-macro-1)
+ (defmacro to-die-for ()
+ :original))
+ :load t)
+
+(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)))))
+
+(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))))))