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