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