0.8.12.15:
[sbcl.git] / 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))
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))
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:noslot)))))
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~%")
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 ;;; WOOT! Done.
439 (sb-ext:quit :unix-status 104)