tests/package-locks.impure.lisp

   1 ;;;; package lock tests with side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (load "assertoid.lisp")
  17 (load "compiler-test-util.lisp")
  18 (use-package "ASSERTOID")
  19
  20 ;;;; Our little labrats and a few utilities
  21
  22 (defpackage :test-used)
  23
  24 (defpackage :test-unused)
  25
  26 (defpackage :test-nicknamed)
  27
  28 (defpackage :test-not-nicknamed)
  29
  30 (defpackage :test-aux (:export #:noslot #:noslot2))
  31
  32 (defpackage :test
  33   (:use :test-used)
  34   (:shadow #:shadowed)
  35   (:export
  36    #:*special*
  37    #:car
  38    #:cdr
  39    #:class
  40    #:constant
  41    #:external
  42    #:function
  43    #:macro
  44    #:noclass
  45    #:noclass-slot
  46    #:nocondition
  47    #:nocondition-slot
  48    #:nospecial
  49    #:nostruct
  50    #:nostruct2
  51    #:nostruct-slot
  52    #:nosymbol-macro
  53    #:notype
  54    #:num
  55    #:numfun
  56    #:shadowed
  57    #:symbol-macro
  58    #:unused
  59    ))
  60
  61 (defvar *uninterned* "UNINTERNED")
  62 (defvar *interned* "INTERNED")
  63
  64 (defun maybe-unintern (name package)
  65     (let ((s (find-symbol name package)))
  66       (when s
  67         (unintern s package))))
  68
  69 (defun set-test-locks (lock-p)
  70   (dolist (p '(:test :test-aux :test-delete))
  71     (when (find-package p)
  72       (if lock-p
  73           (sb-ext:lock-package p)
  74           (sb-ext:unlock-package p)))))
  75
  76 (defun reset-test (lock)
  77   "Reset TEST package to a known state, ensure that TEST-DELETE exists."
  78   (unless (find-package :test-delete)
  79     (make-package :test-delete))
  80   (sb-ext:with-unlocked-packages (:test :test-aux)
  81     (dolist (s '(test:nosymbol-macro
  82                  test:noclass test:nostruct test:nostruct2 test:nocondition))
  83       (makunbound s)
  84       (unintern s)
  85       (intern (symbol-name s) :test))
  86     (rename-package (find-package :test) :test)
  87     (dolist (nickname (package-local-nicknames :test))
  88       (remove-package-local-nickname (car nickname) :test))
  89     (add-package-local-nickname :nicknamed :test-nicknamed :test)
  90     (unexport (intern "INTERNAL" :test) :test)
  91     (intern *interned* :test)
  92     (use-package :test-used :test)
  93     (export 'test::external :test)
  94     (unuse-package :test-unused :test)
  95     (defclass test:class () ())
  96     (defun test:function () 'test:function)
  97     (defmacro test:macro () ''test:macro)
  98     (defparameter test:*special* 'test:*special*)
  99     (defconstant test:constant 'test:constant)
 100     (intern "UNUSED" :test)
 101     (dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot
 102                  test-aux:noslot test-aux:noslot2))
 103       (fmakunbound s))
 104     (ignore-errors (progn
 105                      (fmakunbound 'test:unused)
 106                      (makunbound 'test:unused)))
 107     (maybe-unintern *uninterned* :test)
 108     (maybe-unintern "NOT-FROM-TEST" :test)
 109     (defconstant test:num 0)
 110     (define-symbol-macro test:symbol-macro "SYMBOL-MACRO")
 111     (defun test:numfun (n) n)
 112     (defun test:car (cons) (cl:car cons))
 113     (defun (setf test:cdr) (obj cons) (setf (cl:cdr cons) obj))
 114     (assert (not (find-symbol *uninterned* :test))))
 115   (set-test-locks lock))
 116
 117 (defun tmp-fmakunbound (x)
 118   "FMAKUNDBOUND x, then restore the original binding."
 119   (let ((f (fdefinition x)))
 120     (fmakunbound x)
 121     (ignore-errors (setf (fdefinition x) f))))
 122
 123 (defmacro with-error-info ((string &rest args) &body forms)
 124   `(handler-bind ((error (lambda (e)
 125                            (declare (ignorable e))
 126                            (format t ,string ,@args)
 127                            (finish-output))))
 128      (progn ,@forms)))
 129
 130 ;;;; Test cases
 131
 132 ;;; A collection of forms that are legal both with and without package
 133 ;;; locks.
 134 (defvar *legal-forms*
 135   '(;; package alterations that don't actually mutate the package
 136     (intern *interned* :test)
 137     (import 'test:unused :test)
 138     (shadowing-import 'test:shadowed :test)
 139     (export 'test:unused :test)
 140     (unexport 'test::internal :test)
 141     (let ((p (find-package :test)))
 142       (rename-package p :test))
 143     (use-package :test-used :test)
 144     (unuse-package :test-unused :test)
 145     (shadow "SHADOWED" :test)
 146     (let ((s (with-unlocked-packages (:test)
 147                (let ((s (intern *uninterned* :test)))
 148                  (unintern s :test)
 149                  s))))
 150       (unintern s :test))
 151
 152     ;; binding and altering value
 153     (let ((test:function 123))
 154       (assert (eql test:function 123)))
 155     (let ((test:*special* :foo))
 156       (assert (eql test:*special* :foo)))
 157     (progn
 158       (setf test:*special* :quux)
 159       (assert (eql test:*special* :quux)))
 160     (let ((test:unused :zot))
 161       (assert (eql test:unused :zot)))
 162
 163     ;; symbol-macrolet
 164     (symbol-macrolet ((test:function :sym-ok))
 165         (assert (eql test:function :sym-ok)))
 166     (symbol-macrolet ((test:unused :sym-ok2))
 167         (assert (eql test:unused :sym-ok2)))
 168
 169     ;; binding as a function
 170     (flet ((test:*special* () :yes))
 171       (assert (eql (test:*special*) :yes)))
 172     (flet ((test:unused () :yes!))
 173       (assert (eql (test:unused) :yes!)))
 174     (labels ((test:*special* () :yes))
 175       (assert (eql (test:*special*) :yes)))
 176     (labels ((test:unused () :yes!))
 177       (assert (eql (test:unused) :yes!)))
 178
 179     ;; binding as a macro
 180     (macrolet ((test:*special* () :ok))
 181       (assert (eql (test:*special*) :ok)))
 182     ))
 183
 184 ;;; A collection of forms that cause runtime package lock violations
 185 ;;; on TEST, and will also signal an error on LOAD even if first
 186 ;;; compiled with COMPILE-FILE with TEST unlocked.
 187 (defvar *illegal-runtime-forms*
 188   '(;; package alterations
 189     (intern *uninterned* :test)
 190     (import 'not-from-test :test)
 191     (export 'test::internal :test)
 192     (unexport 'test:external :test)
 193     (shadowing-import 'not-from-test :test)
 194     (let ((p (find-package :test)))
 195       (rename-package p :test '(:test-nick)))
 196     (use-package :test-unused :test)
 197     (unuse-package :test-used :test)
 198     (add-package-local-nickname :not-nicknamed :test-not-nicknamed :test)
 199     (remove-package-local-nickname :nicknamed :test)
 200     (shadow 'not-from-test :test)
 201     (unintern (or (find-symbol *interned* :test) (error "bugo")) :test)
 202     (delete-package :test-delete)
 203
 204     ;; redefining or undefining as a function
 205     (defun test:function () 'foo)
 206     (setf (fdefinition 'test:function) (lambda () 'bar))
 207     (setf (symbol-function 'test:function) (lambda () 'quux))
 208     (tmp-fmakunbound 'test:function)
 209
 210     ;; defining or undefining as a macro or compiler macro
 211     (defmacro test:unused () ''foo)
 212     (setf (macro-function 'test:unused) (constantly 'foo))
 213     (define-compiler-macro test:unused (&whole form arg)
 214       (declare (ignore arg))
 215       form)
 216     (setf (compiler-macro-function 'test:unused) (constantly 'foo))
 217
 218     ;; type-specifier or structure
 219     (progn
 220       (defstruct test:nostruct test:nostruct-slot)
 221       ;; test creation as well, since the structure-class won't be
 222       ;; finalized before that
 223       (make-nostruct :nostruct-slot :foo))
 224     (defclass test:noclass ()
 225       ((slot :initform nil :accessor test:noclass-slot)))
 226     (deftype test:notype () 'string)
 227     (define-condition test:nocondition (error)
 228       ((slot :initform nil :accessor test:nocondition-slot)))
 229
 230     ;; symbol-macro
 231     (define-symbol-macro test:nosymbol-macro 'foo)
 232
 233     ;; declaration proclamation
 234     (proclaim '(declaration test:unused))
 235
 236     ;; declare special
 237     (declaim (special test:nospecial))
 238     (proclaim '(special test:nospecial))
 239
 240     ;; declare type
 241     (declaim (type fixnum test:num))
 242     (proclaim '(type fixnum test:num))
 243
 244     ;; declare ftype
 245     (declaim (ftype (function (fixnum) fixnum) test:numfun))
 246     (proclaim '(ftype (function (fixnum) fixnum) test:numfun))
 247
 248     ;; setf expanders
 249     (defsetf test:car rplaca) ; strictly speaking wrong, but ok as a test
 250     (defsetf test:car (cons) (new-car)
 251       `(setf (car ,cons) ,new-car))
 252     (define-setf-expander test:car (place)
 253       (multiple-value-bind (dummies vals newval setter getter)
 254           (get-setf-expansion place)
 255         (declare (ignore newval setter))
 256         (let ((store (gensym)))
 257           (values dummies
 258                   vals
 259                   `(,store)
 260                   `(progn (rplaca ,getter ,store) ,store)
 261                   `(car ,getter)))))
 262
 263     ;; setf function names
 264     (defun (setf test:function) (obj)
 265       obj)
 266     (tmp-fmakunbound '(setf test:cdr))
 267
 268     ;; define-method-combination
 269     (define-method-combination test:unused)
 270
 271     ;; setf find-class
 272     (setf (find-class 'test:class) (find-class 'standard-class))
 273     ))
 274
 275 ;;; Forms that cause violations on two distinct packages.
 276 (defvar *illegal-double-forms*
 277   '((defclass test:noclass () ((x :accessor test-aux:noslot)))
 278     (define-condition test:nocondition (error)
 279       ((x :accessor test-aux:noslot2)))))
 280
 281 ;;; A collection of forms that cause compile-time package lock
 282 ;;; violations on TEST, and will not signal an error on LOAD if first
 283 ;;; compiled by COMPILE-FILE with test unlocked. CAR is the affected
 284 ;;; symbol, CDR the form affecting it.
 285 (defvar *illegal-lexical-forms-alist*
 286   '(;; binding
 287
 288     ;; binding as a function
 289     (test:function . (flet ((test:function () :shite))
 290                        (test:function)))
 291     (test:function . (labels ((test:function () :shite))
 292                        (test:function)))
 293     (test:macro . (flet ((test:macro () :shite))
 294                     (test:macro)))
 295     (test:macro . (labels ((test:macro () :shite))
 296                     (test:macro)))
 297
 298     ;; macrolet
 299     (test:function . (macrolet ((test:function () :yuk))
 300                        (test:function)))
 301     (test:macro . (macrolet ((test:macro () :yuk))
 302                     (test:macro)))
 303
 304     ;; setf name
 305     (test:function . (flet (((setf test:function) (obj)
 306                               obj))
 307                        (setf (test:function) 1)))
 308
 309     ;; ftype
 310     ;;
 311     ;; The legacy interpreter doesn't do anything with ftype declarations
 312     #+(or :sb-fasteval (not :interpreter))
 313     (test:function . (locally
 314                          (declare (ftype function test:function))
 315                        (cons t t)))
 316
 317     ;; type
 318     ;;
 319     ;; Nor with type declarations
 320     #+(or :sb-fasteval (not :interpreter))
 321     (test:num . (locally
 322                     (declare (type fixnum test:num))
 323                   (cons t t)))
 324
 325     ;; special
 326     (test:nospecial . (locally
 327                           (declare (special test:nospecial))
 328                         (cons t t)))
 329
 330     ;; declare ftype
 331     #+(or :sb-fasteval (not :interpreter))
 332     (test:numfun . (locally
 333                        (declare (ftype (function (fixnum) fixnum) test:numfun))
 334                      (cons t t)))))
 335
 336 (defvar *illegal-lexical-forms*
 337   (mapcar #'cdr *illegal-lexical-forms-alist*))
 338
 339 (defvar *illegal-forms* (append *illegal-runtime-forms*
 340                                 *illegal-lexical-forms*
 341                                 *illegal-double-forms*))
 342
 343 ;;;; Running the tests
 344
 345 ;;; Unlocked. No errors nowhere.
 346 (reset-test nil)
 347
 348 (with-test (:name :unlocked-package)
 349   (dolist (form (append *legal-forms* *illegal-forms*))
 350     (with-error-info ("Unlocked form: ~S~%" form)
 351       (eval form))))
 352
 353 ;;; Locked. Errors for all illegal forms, none for legal.
 354 (reset-test t)
 355
 356 (with-test (:name :locked-package/legal-forms)
 357   (dolist (form *legal-forms*)
 358     (with-error-info ("locked legal form: ~S~%" form)
 359       (eval form))))
 360
 361 (with-test (:name :locked-package/illegal-runtime-forms)
 362   (dolist (form (remove 'declaim (append *illegal-runtime-forms*
 363                                          *illegal-double-forms*)
 364                         :key #'first))
 365     (with-error-info ("locked illegal runtime form: ~S~%" form)
 366       (let ((fun (checked-compile `(lambda () ,form))))
 367         (assert-error (funcall fun) sb-ext:package-lock-violation))
 368       (assert-error (eval form) sb-ext:package-lock-violation))))
 369
 370 (with-test (:name :locked-package/illegal-lexical-forms)
 371   (loop :for (nil . form) :in *illegal-lexical-forms-alist* :do
 372      (with-error-info ("compile locked illegal lexical form: ~S~%" form)
 373        (let ((fun (checked-compile `(lambda () ,form)
 374                                    :allow-failure t
 375                                    :allow-warnings 'simple-warning)))
 376          (assert-error (funcall fun) program-error))
 377        (assert-error (let ((*error-output* (make-broadcast-stream)))
 378                        (eval form))
 379                      ;; Let's not be pedantic here.
 380                      ;; PACKAGE-LOCK-VIOLATION is right,
 381                      ;; because the distinction between lexical analysis
 382                      ;; and running is artificial for interpreted code.
 383                      (or sb-ext:package-lock-violation program-error)))))
 384
 385 ;;; Locked, WITHOUT-PACKAGE-LOCKS
 386 (reset-test t)
 387
 388 (with-test (:name (sb-ext:without-package-locks :locked-package :illegal-runtime-forms))
 389   (dolist (form (remove 'declaim *illegal-runtime-forms* :key #'first))
 390     (with-error-info ("without-package-locks illegal runtime form: ~S~%" form)
 391       (funcall (checked-compile `(lambda () (without-package-locks ,form)))))))
 392
 393 (with-test (:name (sb-ext:without-package-locks :locked-package :illegal-lexical-forms))
 394  (dolist (form *illegal-lexical-forms*)
 395    (let ((fun (without-package-locks (checked-compile `(lambda () ,form)))))
 396      (funcall fun))
 397    (without-package-locks (eval form))))
 398
 399 ;;; Locked, DISABLE-PACKAGE-LOCKS
 400 (reset-test t)
 401
 402 (dolist (pair *illegal-lexical-forms-alist*)
 403   (destructuring-bind (sym . form) pair
 404     (with-error-info ("disable-package-locks on illegal form: ~S~%"
 405                       form)
 406       (funcall (checked-compile `(lambda ()
 407                                    (declare (disable-package-locks ,sym))
 408                                    ,form)))
 409       (eval `(locally
 410                  (declare (disable-package-locks ,sym))
 411                ,form)))))
 412
 413 ;;; Locked, one error per "lexically apparent violated package", also
 414 ;;; test restarts.
 415 (reset-test t)
 416
 417 (with-test (:name :illegal-runtime-forms)
 418  (dolist (form *illegal-runtime-forms*)
 419    (with-error-info ("one error per form ~S~%" form)
 420      (let ((errorp nil))
 421        (handler-bind ((package-lock-violation (lambda (e)
 422                                                 (when errorp
 423                                                   (error "multiple errors ~%~a~% and ~%~a"
 424                                                          errorp e))
 425                                                 (setf errorp e)
 426                                                 (continue e))))
 427          (eval form))))))
 428
 429 (with-test (:name :illegal-double-forms)
 430   (dolist (form *illegal-double-forms*)
 431     (with-error-info ("two errors per form: ~S~%" form)
 432       (let ((error-count 0))
 433         ;; check that we don't get multiple errors from a single form
 434         (handler-bind ((package-lock-violation (lambda (x)
 435                                                  (declare (ignorable x))
 436                                                  (incf error-count)
 437                                                  (continue x))))
 438           (eval form)
 439           (unless (= 2 error-count)
 440             (error "expected 2 errors per form, got ~A for ~A"
 441                    error-count form)))))))
 442
 443 ;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only
 444 ;;;
 445 ;;; This is not part of the interface, but it is the behaviour we want
 446 (with-test (:name (compile-file load :locked-package))
 447   (let* ((tmp "package-locks.tmp.lisp")
 448          (fasl (compile-file-pathname tmp)))
 449     (dolist (form *illegal-runtime-forms*)
 450       (unwind-protect
 451            (with-simple-restart (next "~S failed, continue with next test" form)
 452              (reset-test nil)
 453              (with-open-file (f tmp :direction :output)
 454                (prin1 form f))
 455              (multiple-value-bind (file warnings failure-p) (compile-file tmp)
 456                (declare (ignore file warnings failure-p))
 457                (set-test-locks t)
 458                (assert-error (load fasl) sb-ext:package-lock-violation)))
 459         (when (probe-file tmp)
 460           (delete-file tmp))
 461         (when (probe-file fasl)
 462           (delete-file fasl))))))
 463
 464 ;;;; Tests for enable-package-locks declarations
 465 (reset-test t)
 466
 467 (with-test (:name (sb-ext:enable-package-locks))
 468   (loop :for (sym . form) :in *illegal-lexical-forms-alist* :do
 469      (let ((fun (checked-compile
 470                  `(lambda ()
 471                     (declare (disable-package-locks ,sym))
 472                     ,form
 473                     (locally (declare (enable-package-locks ,sym))
 474                       ,form))
 475                  :allow-failure t
 476                  :allow-warnings 'simple-warning)))
 477        (assert-error (funcall fun) program-error))
 478      (assert-error
 479       (let ((*error-output* (make-broadcast-stream)))
 480         (eval `(locally (declare (disable-package-locks ,sym))
 481                  ,form
 482                  (locally (declare (enable-package-locks ,sym))
 483                    ,form))))
 484       (or sb-ext:package-lock-violation program-error))))
 485
 486 ;;;; See that trace on functions in locked packages doesn't break
 487 ;;;; anything.
 488 (assert (trace test:function :break t))
 489 (untrace test:function)
 490
 491 ;;;; No bogus violations from defclass with accessors in a locked
 492 ;;;; package. Reported by by Francois-Rene Rideau.
 493 (with-test (:name (defclass :accessor :package-locked))
 494   (assert (package-locked-p :sb-gray))
 495   (let ((fun (checked-compile
 496               '(lambda ()
 497                 (defclass fare-class ()
 498                   ((line-column :initform 0 :reader sb-gray:stream-line-column)))))))
 499     (multiple-value-bind (class run-errors) (ignore-errors (funcall fun))
 500       (assert (not run-errors))
 501       (assert (eq class (find-class 'fare-class))))))
 502
 503 ;;;; No bogus violations from DECLARE's done by PCL behind the
 504 ;;;; scenes. Reported by David Wragg on sbcl-help.
 505 (reset-test t)
 506
 507 (defmethod pcl-type-declaration-method-bug ((test:*special* stream))
 508   test:*special*)
 509 (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*)))
 510
 511 ;; Interpreters don't walk into a method body until it's executed.
 512 #-:interpreter
 513 (assert-error
 514  (eval
 515   '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
 516     (declare (type stream test:*special*))
 517     test:*special*))
 518  program-error)
 519
 520 ;;; Bogus package lock violations from LOOP
 521
 522 (with-test (:name (loop :bogus sb-ext:package-lock-violation))
 523   (assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*)
 524                  '(2 3))))
 525
 526 ;;; Package lock for DEFMACRO -> DEFUN and vice-versa.
 527 (reset-test t)
 528 (with-test (:name :bug-576637)
 529   (assert-error (eval `(defun test:macro (x) x))
 530                 sb-ext:package-lock-violation)
 531   (assert (eq 'test:macro (eval `(test:macro))))
 532   (assert-error (eval `(defmacro test:function (x) x))
 533                 sb-ext:package-lock-violation)
 534   (assert (eq 'test:function (eval `(test:function)))))
 535
 536 (defpackage :macro-killing-macro-1
 537   (:use :cl)
 538   (:lock t)
 539   (:export #:to-die-for))
 540
 541 (defpackage :macro-killing-macro-2
 542   (:use :cl :macro-killing-macro-1))
 543
 544 (ctu:file-compile
 545  `((in-package :macro-killing-macro-1)
 546    (defmacro to-die-for ()
 547      :original))
 548  :load t)
 549
 550 (with-test (:name :defmacro-killing-macro)
 551   (ignore-errors
 552     (ctu:file-compile
 553      `((in-package :macro-killing-macro-2)
 554        (defmacro to-die-for ()
 555          :replacement))))
 556   (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
 557
 558 (with-test (:name :setf-macro-function-killing-macro)
 559   (ignore-errors
 560     (ctu:file-compile
 561      `((in-package :macro-killing-macro-2)
 562        (eval-when (:compile-toplevel)
 563          (setf (macro-function 'to-die-for) (constantly :replacement2))))))
 564   (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
 565
 566 (with-test (:name :compile-time-defun-package-locked)
 567   ;; Make sure compile-time side-effects of DEFUN are protected against.
 568   (let ((inline-lambda (function-lambda-expression #'fill-pointer)))
 569     ;; Make sure it's actually inlined...
 570     (assert inline-lambda)
 571     (assert (eq :ok
 572                 (handler-case
 573                     (ctu:file-compile `((defun fill-pointer (x) x)))
 574                   (sb-ext:symbol-package-locked-error (e)
 575                     (when (eq 'fill-pointer
 576                               (sb-ext:package-locked-error-symbol e))
 577                       :ok)))))
 578     (assert (equal inline-lambda
 579                    (function-lambda-expression #'fill-pointer)))))
 580
 581 (with-test (:name :compile-time-defclass-package-locked)
 582   ;; Compiling (DEFCLASS FTYPE ...) used to break SBCL, but the package
 583   ;; locks didn't kick in till later.
 584   (assert (eq :ok
 585               (handler-case
 586                   (ctu:file-compile `((defclass ftype () ())))
 587                 (sb-ext:symbol-package-locked-error (e)
 588                   (when (eq 'ftype (sb-ext:package-locked-error-symbol e))
 589                     :ok)))))
 590   ;; Check for accessor violations as well.
 591   (assert (eq :ok
 592               (handler-case
 593                   (ctu:file-compile `((defclass foo () ((ftype :reader ftype)))))
 594                 (sb-ext:symbol-package-locked-error (e)
 595                   (when (eq 'ftype (sb-ext:package-locked-error-symbol e))
 596                     :ok))))))
 597
 598 (with-test (:name :assert-symbol-home-package-unlocked)
 599   (assert-error                         ; TODO use assert-signals
 600                 (sb-impl::assert-symbol-home-package-unlocked
 601                  'cl:cons "trying to foo ~S")
 602                 symbol-package-locked-error)
 603   (assert-error
 604    (sb-impl::assert-symbol-home-package-unlocked
 605     'cl:cons "trying to ~*~S ~2:*~A~* as a ~S"
 606     :foo :bar)
 607    symbol-package-locked-error))
 608
 609 (with-test (:name :defcostant-locks)
 610   (assert-error (defconstant test:constant 100)
 611                 symbol-package-locked-error))
 612
 613 (with-test (:name :defstruct-compile-time-locks)
 614   (assert-error (ctu:file-compile
 615                  `((defstruct test:nostruct)))
 616       symbol-package-locked-error)
 617   (assert-error (ctu:file-compile
 618                  `((defstruct (a-struct-test.1
 619                                (:conc-name))
 620                      test:nostruct)))
 621       symbol-package-locked-error)
 622   (assert-error (ctu:file-compile
 623                  `((defstruct (a-struct-test.2
 624                                (:predicate test:nostruct)))))
 625       symbol-package-locked-error)
 626   (assert-error (ctu:file-compile
 627                  `((defstruct (a-struct-test.3
 628                                (:copier test:nostruct)))))
 629       symbol-package-locked-error)
 630   (assert-error (ctu:file-compile
 631                  `((defstruct (a-struct-test.4
 632                                (:constructor test:nostruct)))))
 633       symbol-package-locked-error))