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