1 ;;;; package lock tests with side effects
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
16 (load "assertoid.lisp")
17 (load "compiler-test-util.lisp")
18 (use-package "ASSERTOID")
20 ;;;; Our little labrats and a few utilities
22 (defpackage :test-used)
24 (defpackage :test-unused)
26 (defpackage :test-aux (:export #:noslot #:noslot2))
57 (defvar *uninterned* "UNINTERNED")
58 (defvar *interned* "INTERNED")
60 (defun maybe-unintern (name package)
61 (let ((s (find-symbol name package)))
63 (unintern s package))))
65 (defun set-test-locks (lock-p)
66 (dolist (p '(:test :test-aux :test-delete))
67 (when (find-package p)
69 (sb-ext:lock-package p)
70 (sb-ext:unlock-package p)))))
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))
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))
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))
110 (defun tmp-fmakunbound (x)
111 "FMAKUNDBOUND x, then restore the original binding."
112 (let ((f (fdefinition x)))
114 (ignore-errors (setf (fdefinition x) f))))
116 (defmacro with-error-info ((string &rest args) &body forms)
117 `(handler-bind ((error (lambda (e)
118 (format t ,string ,@args)
124 ;;; A collection of forms that are legal both with and without package
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)))
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)))
150 (setf test:*special* :quux)
151 (assert (eql test:*special* :quux)))
152 (let ((test:unused :zot))
153 (assert (eql test:unused :zot)))
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)))
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!)))
171 ;; binding as a macro
172 (macrolet ((test:*special* () :ok))
173 (assert (eql (test:*special*) :ok)))
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)
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)
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)
205 (setf (compiler-macro-function 'test:unused) (constantly 'foo))
207 ;; type-specifier or structure
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)))
220 (define-symbol-macro test:nosymbol-macro 'foo)
222 ;; declaration proclamation
223 (proclaim '(declaration test:unused))
226 (declaim (special test:nospecial))
227 (proclaim '(special test:nospecial))
230 (declaim (type fixnum test:num))
231 (proclaim '(type fixnum test:num))
234 (declaim (ftype (function (fixnum) fixnum) test:numfun))
235 (proclaim '(ftype (function (fixnum) fixnum) test:numfun))
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)))
248 `(progn (rplaca ,getter ,store) ,store)
251 ;; setf function names
252 (defun (setf test:function) (obj)
254 (tmp-fmakunbound '(setf test:cdr))
256 ;; define-method-combination
257 (define-method-combination test:unused)
260 (setf (find-class 'test:class) (find-class 'standard-class))
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)))))
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*
276 ;; binding as a function
277 (test:function . (flet ((test:function () :shite))
279 (test:function . (labels ((test:function () :shite))
281 (test:macro . (flet ((test:macro () :shite))
283 (test:macro . (labels ((test:macro () :shite))
287 (test:function . (macrolet ((test:function () :yuk))
289 (test:macro . (macrolet ((test:macro () :yuk))
293 (test:function . (flet (((setf test:function) (obj)
295 (setf (test:function) 1)))
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))
307 ;; Nor with type declarations
308 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
310 (declare (type fixnum test:num))
314 (test:nospecial . (locally
315 (declare (special test:nospecial))
319 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
320 (test:numfun . (locally
321 (declare (ftype (function (fixnum) fixnum) test:numfun))
324 (defvar *illegal-lexical-forms*
325 (mapcar #'cdr *illegal-lexical-forms-alist*))
327 (defvar *illegal-forms* (append *illegal-runtime-forms*
328 *illegal-lexical-forms*
329 *illegal-double-forms*))
331 ;;;; Running the tests
333 ;;; Unlocked. No errors nowhere.
336 (with-test (:name :unlocked-package)
337 (dolist (form (append *legal-forms* *illegal-forms*))
338 (with-error-info ("~Unlocked form: ~S~%" form)
341 ;;; Locked. Errors for all illegal forms, none for legal.
344 (with-test (:name :locked-package/legal-forms)
345 (dolist (form *legal-forms*)
346 (with-error-info ("locked legal form: ~S~%" form)
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)))))
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))))))
364 ;;; Locked, WITHOUT-PACKAGE-LOCKS
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))))))
371 (dolist (form *illegal-lexical-forms*)
372 (let ((fun (without-package-locks (compile nil `(lambda () ,form)))))
374 (without-package-locks (eval form)))
376 ;;; Locked, DISABLE-PACKAGE-LOCKS
379 (dolist (pair *illegal-lexical-forms-alist*)
380 (destructuring-bind (sym . form) pair
381 (with-error-info ("disable-package-locks on illegal form: ~S~%"
383 (funcall (compile nil `(lambda ()
384 (declare (disable-package-locks ,sym))
387 (declare (disable-package-locks ,sym))
390 ;;; Locked, one error per "lexically apparent violated package", also
394 (dolist (form *illegal-runtime-forms*)
395 (with-error-info ("one error per form ~S~%" form)
397 (handler-bind ((package-lock-violation (lambda (e)
399 (error "multiple errors"))
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)
413 (unless (= 2 error-count)
414 (error "expected 2 errors per form, got ~A for ~A"
415 error-count form))))))
417 ;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only
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))
423 (dolist (form *illegal-runtime-forms*)
425 (with-simple-restart (next "~S failed, continue with next test" form)
427 (with-open-file (f tmp :direction :output)
429 (multiple-value-bind (file warnings failure-p) (compile-file tmp)
431 (assert (raises-error? (load fasl)
432 sb-ext:package-lock-violation))))
433 (when (probe-file tmp)
435 (when (probe-file fasl)
436 (delete-file fasl)))))
438 ;;;; Tests for enable-package-locks declarations
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))
446 (locally (declare (enable-package-locks ,sym))
448 (assert (raises-error? (funcall fun) program-error)))
449 (assert (raises-error?
450 (eval `(locally (declare (disable-package-locks ,sym))
452 (locally (declare (enable-package-locks ,sym))
456 ;;;; See that trace on functions in locked packages doesn't break
458 (assert (trace test:function :break t))
459 (untrace test:function)
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)
469 (defclass fare-class ()
470 ((line-column :initform 0 :reader sb-gray:stream-line-column))))))
471 (assert (not compile-errors))
473 (multiple-value-bind (class run-errors) (ignore-errors (funcall fun))
474 (assert (not run-errors))
475 (assert (eq class (find-class 'fare-class)))))
477 ;;;; No bogus violations from DECLARE's done by PCL behind the
478 ;;;; scenes. Reported by David Wragg on sbcl-help.
481 (defmethod pcl-type-declaration-method-bug ((test:*special* stream))
483 (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*)))
485 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
486 (assert (raises-error?
488 '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
489 (declare (type stream test:*special*))
493 ;;; Bogus package lock violations from LOOP
495 (assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*)
498 ;;; Package lock for DEFMACRO -> DEFUN and vice-versa.
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)))))
508 (defpackage :macro-killing-macro-1
511 (:export #:to-die-for))
513 (defpackage :macro-killing-macro-2
514 (:use :cl :macro-killing-macro-1))
517 `((in-package :macro-killing-macro-1)
518 (defmacro to-die-for ()
522 (with-test (:name :defmacro-killing-macro)
525 `((in-package :macro-killing-macro-2)
526 (defmacro to-die-for ()
528 (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
530 (with-test (:name :setf-macro-function-killing-macro)
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)))))
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)
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))
550 (assert (equal inline-lambda
551 (function-lambda-expression #'fill-pointer)))))
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.
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))
562 ;; Check for accessor violations as well.
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))