;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(defun reset-test ()
"Reset TEST package to a known state, ensure that TEST-DELETE exists."
(unless (find-package :test-delete)
(make-package :test-delete))
(sb-ext:with-unlocked-packages (:test :test-aux)
(defun reset-test ()
"Reset TEST package to a known state, ensure that TEST-DELETE exists."
(unless (find-package :test-delete)
(make-package :test-delete))
(sb-ext:with-unlocked-packages (:test :test-aux)
(unexport (intern "INTERNAL" :test) :test)
(intern *interned* :test)
(use-package :test-used :test)
(unexport (intern "INTERNAL" :test) :test)
(intern *interned* :test)
(use-package :test-used :test)
(defconstant test:constant 'test:constant)
(intern "UNUSED" :test)
(dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot
(defconstant test:constant 'test:constant)
(intern "UNUSED" :test)
(dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot
(use-package :test-used :test)
(unuse-package :test-unused :test)
(shadow "SHADOWED" :test)
(use-package :test-used :test)
(unuse-package :test-unused :test)
(shadow "SHADOWED" :test)
(assert (eql test:*special* :quux)))
(let ((test:unused :zot))
(assert (eql test:unused :zot)))
(assert (eql test:*special* :quux)))
(let ((test:unused :zot))
(assert (eql test:unused :zot)))
;; defining or undefining as a macro or compiler macro
(defmacro test:unused () ''foo)
(setf (macro-function 'test:unused) (constantly 'foo))
;; defining or undefining as a macro or compiler macro
(defmacro test:unused () ''foo)
(setf (macro-function 'test:unused) (constantly 'foo))
;; type-specifier or structure
(progn
(defstruct test:nostruct test:nostruct-slot)
;; test creation as well, since the structure-class won't be
;; finalized before that
(make-nostruct :nostruct-slot :foo))
;; type-specifier or structure
(progn
(defstruct test:nostruct test:nostruct-slot)
;; test creation as well, since the structure-class won't be
;; finalized before that
(make-nostruct :nostruct-slot :foo))
((slot :initform nil :accessor test:noclass-slot)))
(deftype test:notype () 'string)
(define-condition test:nocondition (error)
((slot :initform nil :accessor test:noclass-slot)))
(deftype test:notype () 'string)
(define-condition test:nocondition (error)
`(setf (car ,cons) ,new-car))
(define-setf-expander test:car (place)
(multiple-value-bind (dummies vals newval setter getter)
`(setf (car ,cons) ,new-car))
(define-setf-expander test:car (place)
(multiple-value-bind (dummies vals newval setter getter)
- (eval form)
- (unless (= 2 error-count)
- (error "expected 2 errors per form, got ~A for ~A"
- error-count form))))))
+ (eval form)
+ (unless (= 2 error-count)
+ (error "expected 2 errors per form, got ~A for ~A"
+ error-count form))))))
;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only
(let* ((tmp "package-locks.tmp.lisp")
;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only
(let* ((tmp "package-locks.tmp.lisp")
- (with-simple-restart (next "~S failed, continue with next test" form)
- (reset-test)
- (set-test-locks nil)
- (with-open-file (f tmp :direction :output)
- (prin1 form f))
- (multiple-value-bind (file warnings failure-p) (compile-file tmp)
- (set-test-locks t)
- (assert (raises-error? (load fasl) sb-ext:package-lock-violation))))
+ (with-simple-restart (next "~S failed, continue with next test" form)
+ (reset-test)
+ (set-test-locks nil)
+ (with-open-file (f tmp :direction :output)
+ (prin1 form f))
+ (multiple-value-bind (file warnings failure-p) (compile-file tmp)
+ (set-test-locks t)
+ (assert (raises-error? (load fasl) sb-ext:package-lock-violation))))
-(reset-test)
-(set-test-locks t)
-(dolist (pair *illegal-compile-time-forms-alist*)
- (destructuring-bind (sym . form) pair
+;;;; In addition to that, this is also testing for bug 387
+(with-test (:name :program-error
+ :fails-on :sbcl)
+ (reset-test)
+ (set-test-locks t)
+ (dolist (pair *illegal-compile-time-forms-alist*)
+ (destructuring-bind (sym . form) pair
;;;; See that trace on functions in locked packages doesn't break
;;;; anything.
(assert (trace test:function :break t))
;;;; No bogus violations from defclass with accessors in a locked
;;;; See that trace on functions in locked packages doesn't break
;;;; anything.
(assert (trace test:function :break t))
;;;; No bogus violations from defclass with accessors in a locked
- (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
- (declare (type stream test:*special*))
- test:*special*))
- package-lock-violation))
+ (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream))
+ (declare (type stream test:*special*))
+ test:*special*))
+ package-lock-violation))