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