X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackage-locks.impure.lisp;h=77b2a9edfa9b043bb2fd46fe27a7b4251da76170;hb=9f29c03145c7fdefc5f54939d67ee8e00cd85f14;hp=9a1b121e8d34f18f867388d99bc96b2507cf470c;hpb=0eb4279ffb12ccd0f70cb18c2aa3785184127b6b;p=sbcl.git diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 9a1b121..77b2a9e 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -6,7 +6,7 @@ ;;;; 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. @@ -25,12 +25,12 @@ (defpackage :test-unused) -(defpackage :test-aux (:export #:noslot)) +(defpackage :test-aux (:export #:noslot #:noslot2)) (defpackage :test (:use :test-used) (:shadow #:shadowed) - (:export + (:export #:*special* #:car #:cdr @@ -62,26 +62,26 @@ (defun maybe-unintern (name package) (let ((s (find-symbol name package))) (when s - (unintern s package)))) + (unintern s package)))) (defun set-test-locks (lock-p) (dolist (p '(:test :test-aux :test-delete)) (when (find-package p) (if lock-p - (sb-ext:lock-package p) - (sb-ext:unlock-package p))))) + (sb-ext:lock-package p) + (sb-ext:unlock-package p))))) (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) - (dolist (s '(test:nosymbol-macro - test:noclass test:nostruct test:nostruct2 test:nocondition)) + (dolist (s '(test:nosymbol-macro + test:noclass test:nostruct test:nostruct2 test:nocondition)) (makunbound s) (unintern s) (intern (symbol-name s) :test)) - (rename-package (find-package :test) :test) + (rename-package (find-package :test) :test) (unexport (intern "INTERNAL" :test) :test) (intern *interned* :test) (use-package :test-used :test) @@ -94,11 +94,11 @@ (defconstant test:constant 'test:constant) (intern "UNUSED" :test) (dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot - test-aux:noslot)) + test-aux:noslot test-aux:noslot2)) (fmakunbound s)) (ignore-errors (progn - (fmakunbound 'test:unused) - (makunbound 'test:unused))) + (fmakunbound 'test:unused) + (makunbound 'test:unused))) (maybe-unintern *uninterned* :test) (maybe-unintern "NOT-FROM-TEST" :test) (defconstant test:num 0) @@ -116,8 +116,8 @@ (defmacro with-error-info ((string &rest args) &body forms) `(handler-bind ((error (lambda (e) - (format t ,string ,@args) - (finish-output)))) + (format t ,string ,@args) + (finish-output)))) (progn ,@forms))) ;;;; Test cases @@ -136,10 +136,10 @@ (use-package :test-used :test) (unuse-package :test-unused :test) (shadow "SHADOWED" :test) - (let ((s (with-unlocked-packages (:test) - (let ((s (intern *uninterned* :test))) - (unintern s :test) - s)))) + (let ((s (with-unlocked-packages (:test) + (let ((s (intern *uninterned* :test))) + (unintern s :test) + s)))) (unintern s :test)) ;; binding and altering value @@ -152,7 +152,7 @@ (assert (eql test:*special* :quux))) (let ((test:unused :zot)) (assert (eql test:unused :zot))) - + ;; symbol-macrolet (symbol-macrolet ((test:function :sym-ok)) (assert (eql test:function :sym-ok))) @@ -201,17 +201,17 @@ ;; defining or undefining as a macro or compiler macro (defmacro test:unused () ''foo) (setf (macro-function 'test:unused) (constantly 'foo)) - (define-compiler-macro test:unused (&whole form arg) + (define-compiler-macro test:unused (&whole form arg) form) (setf (compiler-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)) - (defclass test:noclass () + (defclass test:noclass () ((slot :initform nil :accessor test:noclass-slot))) (deftype test:notype () 'string) (define-condition test:nocondition (error) @@ -241,7 +241,7 @@ `(setf (car ,cons) ,new-car)) (define-setf-expander test:car (place) (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) + (get-setf-expansion place) (let ((store (gensym))) (values dummies vals @@ -252,11 +252,11 @@ ;; setf function names (defun (setf test:function) (obj) obj) - (tmp-fmakunbound '(setf test:cdr)) - + (tmp-fmakunbound '(setf test:cdr)) + ;; define-method-combination (define-method-combination test:unused) - + ;; setf find-class (setf (find-class 'test:class) (find-class 'standard-class)) )) @@ -265,7 +265,7 @@ (defvar *illegal-double-forms* '((defclass test:noclass () ((x :accessor test-aux:noslot))) (define-condition test:nocondition (error) - ((x :accessor test-aux:noslot))))) + ((x :accessor test-aux:noslot2))))) ;;; A collection of forms that cause compile-time package lock ;;; violations on TEST, and will not signal an error on LOAD if first @@ -304,7 +304,7 @@ (test:num . (locally (declare (type fixnum test:num)) (cons t t))) - + ;; special (test:nospecial . (locally (declare (special test:nospecial)) @@ -376,7 +376,7 @@ (reset-test) (set-test-locks t) (dolist (form (append *illegal-runtime-forms* *illegal-compile-time-forms*)) - (with-error-info ("one error per form: ~S~%") + (with-error-info ("one error per form: ~S~%" form) (let ((errorp nil)) (handler-bind ((package-lock-violation (lambda (e) (when errorp @@ -392,10 +392,10 @@ (declare (ignore x)) (incf error-count) (continue x)))) - (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") @@ -403,18 +403,18 @@ (n 0)) (dolist (form *illegal-runtime-forms*) (unwind-protect - (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)))) (when (probe-file tmp) - (delete-file tmp)) + (delete-file tmp)) (when (probe-file fasl) - (delete-file fasl))))) + (delete-file fasl))))) ;;;; Tests for enable-package-locks declarations (reset-test) @@ -435,9 +435,49 @@ ,form))) package-lock-violation)))) +;;;; Program-errors from lexical violations +;;;; 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 + (declare (ignore sym)) + (let ((fun (compile nil `(lambda () + ,form)))) + (assert (raises-error? (funcall fun) program-error)))))) + ;;;; 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 +;;;; package. Reported by by Francois-Rene Rideau. +(assert (package-locked-p :sb-gray)) +(multiple-value-bind (fun compile-errors) + (ignore-errors + (compile nil + '(lambda () + (defclass fare-class () + ((line-column :initform 0 :reader sb-gray:stream-line-column)))))) + (assert (not compile-errors)) + (assert fun) + (multiple-value-bind (class run-errors) (ignore-errors (funcall fun)) + (assert (not run-errors)) + (assert (eq class (find-class 'fare-class))))) + +;;;; No bogus violations from DECLARE's done by PCL behind the +;;;; scenes. Reported by David Wragg on sbcl-help. +(reset-test) +(set-test-locks t) +(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + test:*special*) +(assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) +(assert (raises-error? + (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + (declare (type stream test:*special*)) + test:*special*)) + package-lock-violation)) + ;;; WOOT! Done. -(sb-ext:quit :unix-status 104)