Add :application-type parameter for save-lisp-and-die on Windows.
[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 (load "compiler-test-util.lisp")
18 (use-package "ASSERTOID")
19
20 ;;;; Our little labrats and a few utilities
21
22 (defpackage :test-used)
23
24 (defpackage :test-unused)
25
26 (defpackage :test-aux (:export #:noslot #:noslot2))
27
28 (defpackage :test
29   (:use :test-used)
30   (:shadow #:shadowed)
31   (:export
32    #:*special*
33    #:car
34    #:cdr
35    #:class
36    #:constant
37    #:external
38    #:function
39    #:macro
40    #:noclass
41    #:noclass-slot
42    #:nocondition
43    #:nocondition-slot
44    #:nospecial
45    #:nostruct
46    #:nostruct2
47    #:nostruct-slot
48    #:nosymbol-macro
49    #:notype
50    #:num
51    #:numfun
52    #:shadowed
53    #:symbol-macro
54    #:unused
55    ))
56
57 (defvar *uninterned* "UNINTERNED")
58 (defvar *interned* "INTERNED")
59
60 (defun maybe-unintern (name package)
61     (let ((s (find-symbol name package)))
62       (when s
63         (unintern s package))))
64
65 (defun set-test-locks (lock-p)
66   (dolist (p '(:test :test-aux :test-delete))
67     (when (find-package p)
68       (if lock-p
69           (sb-ext:lock-package p)
70           (sb-ext:unlock-package p)))))
71
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))
79       (makunbound s)
80       (unintern s)
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))
96       (fmakunbound s))
97     (ignore-errors (progn
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))
109
110 (defun tmp-fmakunbound (x)
111   "FMAKUNDBOUND x, then restore the original binding."
112   (let ((f (fdefinition x)))
113     (fmakunbound x)
114     (ignore-errors (setf (fdefinition x) f))))
115
116 (defmacro with-error-info ((string &rest args) &body forms)
117   `(handler-bind ((error (lambda (e)
118                            (format t ,string ,@args)
119                            (finish-output))))
120      (progn ,@forms)))
121
122 ;;;; Test cases
123
124 ;;; A collection of forms that are legal both with and without package
125 ;;; locks.
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)))
140                  (unintern s :test)
141                  s))))
142       (unintern s :test))
143
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)))
149     (progn
150       (setf test:*special* :quux)
151       (assert (eql test:*special* :quux)))
152     (let ((test:unused :zot))
153       (assert (eql test:unused :zot)))
154
155     ;; symbol-macrolet
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)))
160
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!)))
170
171     ;; binding as a macro
172     (macrolet ((test:*special* () :ok))
173       (assert (eql (test:*special*) :ok)))
174     ))
175
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)
193
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)
199
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)
204       form)
205     (setf (compiler-macro-function 'test:unused) (constantly 'foo))
206
207     ;; type-specifier or structure
208     (progn
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)))
218
219     ;; symbol-macro
220     (define-symbol-macro test:nosymbol-macro 'foo)
221
222     ;; declaration proclamation
223     (proclaim '(declaration test:unused))
224
225     ;; declare special
226     (declaim (special test:nospecial))
227     (proclaim '(special test:nospecial))
228
229     ;; declare type
230     (declaim (type fixnum test:num))
231     (proclaim '(type fixnum test:num))
232
233     ;; declare ftype
234     (declaim (ftype (function (fixnum) fixnum) test:numfun))
235     (proclaim '(ftype (function (fixnum) fixnum) test:numfun))
236
237     ;; setf expanders
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)))
245           (values dummies
246                   vals
247                   `(,store)
248                   `(progn (rplaca ,getter ,store) ,store)
249                   `(car ,getter)))))
250
251     ;; setf function names
252     (defun (setf test:function) (obj)
253       obj)
254     (tmp-fmakunbound '(setf test:cdr))
255
256     ;; define-method-combination
257     (define-method-combination test:unused)
258
259     ;; setf find-class
260     (setf (find-class 'test:class) (find-class 'standard-class))
261     ))
262
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)))))
268
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*
274   '(;; binding
275
276     ;; binding as a function
277     (test:function . (flet ((test:function () :shite))
278                        (test:function)))
279     (test:function . (labels ((test:function () :shite))
280                        (test:function)))
281     (test:macro . (flet ((test:macro () :shite))
282                     (test:macro)))
283     (test:macro . (labels ((test:macro () :shite))
284                     (test:macro)))
285
286     ;; macrolet
287     (test:function . (macrolet ((test:function () :yuk))
288                        (test:function)))
289     (test:macro . (macrolet ((test:macro () :yuk))
290                     (test:macro)))
291
292     ;; setf name
293     (test:function . (flet (((setf test:function) (obj)
294                               obj))
295                        (setf (test:function) 1)))
296
297     ;; ftype
298     ;;
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))
303                        (cons t t)))
304
305     ;; type
306     ;;
307     ;; Nor with type declarations
308     #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
309     (test:num . (locally
310                     (declare (type fixnum test:num))
311                   (cons t t)))
312
313     ;; special
314     (test:nospecial . (locally
315                           (declare (special test:nospecial))
316                         (cons t t)))
317
318     ;; declare ftype
319     #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
320     (test:numfun . (locally
321                        (declare (ftype (function (fixnum) fixnum) test:numfun))
322                      (cons t t)))))
323
324 (defvar *illegal-lexical-forms*
325   (mapcar #'cdr *illegal-lexical-forms-alist*))
326
327 (defvar *illegal-forms* (append *illegal-runtime-forms*
328                                 *illegal-lexical-forms*
329                                 *illegal-double-forms*))
330
331 ;;;; Running the tests
332
333 ;;; Unlocked. No errors nowhere.
334 (reset-test nil)
335
336 (with-test (:name :unlocked-package)
337   (dolist (form (append *legal-forms* *illegal-forms*))
338     (with-error-info ("~Unlocked form: ~S~%" form)
339       (eval form))))
340
341 ;;; Locked. Errors for all illegal forms, none for legal.
342 (reset-test t)
343
344 (with-test (:name :locked-package/legal-forms)
345   (dolist (form *legal-forms*)
346     (with-error-info ("locked legal form: ~S~%" form)
347       (eval form))))
348
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)))))
355
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))))))
363
364 ;;; Locked, WITHOUT-PACKAGE-LOCKS
365 (reset-test t)
366
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))))))
370
371 (dolist (form *illegal-lexical-forms*)
372   (let ((fun (without-package-locks (compile nil `(lambda () ,form)))))
373     (funcall fun))
374   (without-package-locks (eval form)))
375
376 ;;; Locked, DISABLE-PACKAGE-LOCKS
377 (reset-test t)
378
379 (dolist (pair *illegal-lexical-forms-alist*)
380   (destructuring-bind (sym . form) pair
381     (with-error-info ("disable-package-locks on illegal form: ~S~%"
382                       form)
383       (funcall (compile nil `(lambda ()
384                               (declare (disable-package-locks ,sym))
385                               ,form)))
386       (eval `(locally
387                  (declare (disable-package-locks ,sym))
388                ,form)))))
389
390 ;;; Locked, one error per "lexically apparent violated package", also
391 ;;; test restarts.
392 (reset-test t)
393
394 (dolist (form *illegal-runtime-forms*)
395   (with-error-info ("one error per form ~S~%" form)
396     (let ((errorp nil))
397       (handler-bind ((package-lock-violation (lambda (e)
398                                                (when errorp
399                                                  (error "multiple errors"))
400                                                (setf errorp t)
401                                                (continue e))))
402         (eval form)))))
403
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)
409                                                (declare (ignore x))
410                                                (incf error-count)
411                                                (continue x))))
412         (eval form)
413         (unless (= 2 error-count)
414           (error "expected 2 errors per form, got ~A for ~A"
415                  error-count form))))))
416
417 ;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only
418 ;;;
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))
422        (n 0))
423   (dolist (form *illegal-runtime-forms*)
424     (unwind-protect
425          (with-simple-restart (next "~S failed, continue with next test" form)
426            (reset-test nil)
427            (with-open-file (f tmp :direction :output)
428              (prin1 form f))
429            (multiple-value-bind (file warnings failure-p) (compile-file tmp)
430              (set-test-locks t)
431              (assert (raises-error? (load fasl)
432                                     sb-ext:package-lock-violation))))
433       (when (probe-file tmp)
434         (delete-file tmp))
435       (when (probe-file fasl)
436         (delete-file fasl)))))
437
438 ;;;; Tests for enable-package-locks declarations
439 (reset-test t)
440
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))
445                                ,form
446                                (locally (declare (enable-package-locks ,sym))
447                                  ,form)))))
448       (assert (raises-error? (funcall fun) program-error)))
449     (assert (raises-error?
450              (eval `(locally (declare (disable-package-locks ,sym))
451                       ,form
452                       (locally (declare (enable-package-locks ,sym))
453                         ,form)))
454              program-error))))
455
456 ;;;; See that trace on functions in locked packages doesn't break
457 ;;;; anything.
458 (assert (trace test:function :break t))
459 (untrace test:function)
460
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)
465     (ignore-errors
466       (compile
467        nil
468        '(lambda ()
469          (defclass fare-class ()
470            ((line-column :initform 0 :reader sb-gray:stream-line-column))))))
471   (assert (not compile-errors))
472   (assert fun)
473   (multiple-value-bind (class run-errors) (ignore-errors (funcall fun))
474     (assert (not run-errors))
475     (assert (eq class (find-class 'fare-class)))))
476
477 ;;;; No bogus violations from DECLARE's done by PCL behind the
478 ;;;; scenes. Reported by David Wragg on sbcl-help.
479 (reset-test t)
480
481 (defmethod pcl-type-declaration-method-bug ((test:*special* stream))
482   test:*special*)
483 (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*)))
484
485 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
486 (assert (raises-error?
487          (eval
488           '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
489             (declare (type stream test:*special*))
490             test:*special*))
491          program-error))
492
493 ;;; Bogus package lock violations from LOOP
494
495 (assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*)
496                '(2 3)))
497
498 ;;; Package lock for DEFMACRO -> DEFUN and vice-versa.
499 (reset-test t)
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)))))
507
508 (defpackage :macro-killing-macro-1
509   (:use :cl)
510   (:lock t)
511   (:export #:to-die-for))
512
513 (defpackage :macro-killing-macro-2
514   (:use :cl :macro-killing-macro-1))
515
516 (ctu:file-compile
517  `((in-package :macro-killing-macro-1)
518    (defmacro to-die-for ()
519      :original))
520  :load t)
521
522 (with-test (:name :defmacro-killing-macro)
523   (ignore-errors
524     (ctu:file-compile
525      `((in-package :macro-killing-macro-2)
526        (defmacro to-die-for ()
527          :replacement))))
528   (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for)))))
529
530 (with-test (:name :setf-macro-function-killing-macro)
531   (ignore-errors
532     (ctu:file-compile
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)))))
537
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)
543     (assert (eq :ok
544                 (handler-case
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))
549                       :ok)))))
550     (assert (equal inline-lambda
551                    (function-lambda-expression #'fill-pointer)))))
552
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.
556   (assert (eq :ok
557               (handler-case
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))
561                     :ok)))))
562   ;; Check for accessor violations as well.
563   (assert (eq :ok
564               (handler-case
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))
568                     :ok))))))
569
570 ;;; WOOT! Done.