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