1.0.23.21: Stack allocated conses for MIPS.
[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 ;;;; 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 ;;; Bogus package lock violations from LOOP
488
489 (assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*)
490                '(2 3)))
491
492 ;;; WOOT! Done.