X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackage-locks.impure.lisp;h=485f0eab65c2ffd29ef7997bb8fdc6b43836e673;hb=cf49f2d086069a9c1b57f501df9a6a0bd3a34c3c;hp=427a8ec3bf5b735c1473287d3ebb217ecb4eebec;hpb=67dc5cf478dfe5e3f517001febb9a8f7b922eacf;p=sbcl.git diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 427a8ec..485f0ea 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. @@ -14,11 +14,9 @@ (in-package :cl-user) (load "assertoid.lisp") +(load "compiler-test-util.lisp") (use-package "ASSERTOID") -#-sb-package-locks -(sb-ext:quit :unix-status 104) - ;;;; Our little labrats and a few utilities (defpackage :test-used) @@ -30,7 +28,7 @@ (defpackage :test (:use :test-used) (:shadow #:shadowed) - (:export + (:export #:*special* #:car #:cdr @@ -62,26 +60,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 () +(defun reset-test (lock) "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 +92,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:noslot2)) + 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) @@ -106,7 +104,8 @@ (defun test:numfun (n) n) (defun test:car (cons) (cl:car cons)) (defun (setf test:cdr) (obj cons) (setf (cl:cdr cons) obj)) - (assert (not (find-symbol *uninterned* :test))))) + (assert (not (find-symbol *uninterned* :test)))) + (set-test-locks lock)) (defun tmp-fmakunbound (x) "FMAKUNDBOUND x, then restore the original binding." @@ -116,8 +115,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 +135,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 +151,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))) @@ -192,26 +191,26 @@ (unintern (or (find-symbol *interned* :test) (error "bugo")) :test) (delete-package :test-delete) - ;; defining or undefining as a function - (defun test:unused () 'foo) - (setf (fdefinition 'test:unused) (lambda () 'bar)) - (setf (symbol-function 'test:unused) (lambda () 'quux)) + ;; redefining or undefining as a function + (defun test:function () 'foo) + (setf (fdefinition 'test:function) (lambda () 'bar)) + (setf (symbol-function 'test:function) (lambda () 'quux)) (tmp-fmakunbound 'test:function) ;; 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 +240,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 +251,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)) )) @@ -271,7 +270,7 @@ ;;; violations on TEST, and will not signal an error on LOAD if first ;;; compiled by COMPILE-FILE with test unlocked. CAR is the affected ;;; symbol, CDR the form affecting it. -(defvar *illegal-compile-time-forms-alist* +(defvar *illegal-lexical-forms-alist* '(;; binding ;; binding as a function @@ -296,87 +295,104 @@ (setf (test:function) 1))) ;; ftype + ;; + ;; The interpreter doesn't do anything with ftype declarations + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:function . (locally (declare (ftype function test:function)) (cons t t))) ;; type + ;; + ;; Nor with type declarations + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:num . (locally (declare (type fixnum test:num)) (cons t t))) - + ;; special (test:nospecial . (locally (declare (special test:nospecial)) (cons t t))) ;; declare ftype + #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (test:numfun . (locally (declare (ftype (function (fixnum) fixnum) test:numfun)) (cons t t))))) -(defvar *illegal-compile-time-forms* (mapcar #'cdr *illegal-compile-time-forms-alist*)) +(defvar *illegal-lexical-forms* + (mapcar #'cdr *illegal-lexical-forms-alist*)) (defvar *illegal-forms* (append *illegal-runtime-forms* - *illegal-compile-time-forms* + *illegal-lexical-forms* *illegal-double-forms*)) ;;;; Running the tests ;;; Unlocked. No errors nowhere. -(reset-test) -(set-test-locks nil) -(dolist (form (append *legal-forms* *illegal-forms*)) - (with-error-info ("~Unlocked form: ~S~%" form) - (eval form))) +(reset-test nil) + +(with-test (:name :unlocked-package) + (dolist (form (append *legal-forms* *illegal-forms*)) + (with-error-info ("~Unlocked form: ~S~%" form) + (eval form)))) ;;; Locked. Errors for all illegal forms, none for legal. -(reset-test) -(set-test-locks t) -(dolist (form *legal-forms*) - (with-error-info ("locked legal form: ~S~%" form) - (eval form))) -(reset-test) -(set-test-locks t) -(dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) - (with-error-info ("locked illegal runtime form: ~S~%" form) - (let ((fun (compile nil `(lambda () ,form)))) - (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))))) -(dolist (pair *illegal-compile-time-forms-alist*) - (let ((form (cdr pair))) - (with-error-info ("locked illegal compile-time form: ~S~%" form) - (assert (raises-error? (compile nil `(lambda () ,form)) sb-ext:package-lock-violation))))) - -;;; Locked, WITHOUT-PACKAGE-LOCKS for runtime errors. -(reset-test) -(set-test-locks t) +(reset-test t) + +(with-test (:name :locked-package/legal-forms) + (dolist (form *legal-forms*) + (with-error-info ("locked legal form: ~S~%" form) + (eval form)))) + +(with-test (:name :locked-package/illegal-runtime-forms) + (dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) + (with-error-info ("locked illegal runtime form: ~S~%" form) + (let ((fun (compile nil `(lambda () ,form)))) + (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))) + (assert (raises-error? (eval form) sb-ext:package-lock-violation))))) + +(with-test (:name :locked-package/illegal-lexical-forms) + (dolist (pair *illegal-lexical-forms-alist*) + (let ((form (cdr pair))) + (with-error-info ("compile locked illegal lexical form: ~S~%" form) + (let ((fun (compile nil `(lambda () ,form)))) + (assert (raises-error? (funcall fun) program-error))) + (assert (raises-error? (eval form) program-error)))))) + +;;; Locked, WITHOUT-PACKAGE-LOCKS +(reset-test t) + (dolist (form *illegal-runtime-forms*) (with-error-info ("without-package-locks illegal runtime form: ~S~%" form) (funcall (compile nil `(lambda () (without-package-locks ,form)))))) -;;; Locked, WITHOUT-PACKAGE-LOCKS & DISABLE-PACKAGE-LOCKS for compile-time errors. -(reset-test) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) - (destructuring-bind (sym . form) pair - (with-error-info ("without-package-locks illegal compile-time form: ~S~%" form) - (let ((fun (without-package-locks (compile nil `(lambda () ,form))))) - (funcall fun))))) -(reset-test) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) +(dolist (form *illegal-lexical-forms*) + (let ((fun (without-package-locks (compile nil `(lambda () ,form))))) + (funcall fun)) + (without-package-locks (eval form))) + +;;; Locked, DISABLE-PACKAGE-LOCKS +(reset-test t) + +(dolist (pair *illegal-lexical-forms-alist*) (destructuring-bind (sym . form) pair - (with-error-info ("disable-package-locks illegal compile-time form: ~S~%" form) + (with-error-info ("disable-package-locks on illegal form: ~S~%" + form) (funcall (compile nil `(lambda () (declare (disable-package-locks ,sym)) - ,form)))))) + ,form))) + (eval `(locally + (declare (disable-package-locks ,sym)) + ,form))))) ;;; Locked, one error per "lexically apparent violated package", also ;;; test restarts. -(reset-test) -(set-test-locks t) -(dolist (form (append *illegal-runtime-forms* *illegal-compile-time-forms*)) - (with-error-info ("one error per form: ~S~%" form) +(reset-test t) + +(dolist (form *illegal-runtime-forms*) + (with-error-info ("one error per form ~S~%" form) (let ((errorp nil)) (handler-bind ((package-lock-violation (lambda (e) (when errorp @@ -384,6 +400,7 @@ (setf errorp t) (continue e)))) (eval form))))) + (dolist (form *illegal-double-forms*) (with-error-info ("two errors per form: ~S~%" form) (let ((error-count 0)) @@ -392,72 +409,65 @@ (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 +;;; +;;; This is not part of the interface, but it is the behaviour we want (let* ((tmp "package-locks.tmp.lisp") (fasl (compile-file-pathname tmp)) (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 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) -(set-test-locks t) -(dolist (pair *illegal-compile-time-forms-alist*) +(reset-test t) + +(dolist (pair *illegal-lexical-forms-alist*) (destructuring-bind (sym . form) pair - (assert (raises-error? - (compile nil `(lambda () - (declare (disable-package-locks ,sym)) - ,form - (locally (declare (enable-package-locks ,sym)) - ,form))) - package-lock-violation)) + (let ((fun (compile nil `(lambda () + (declare (disable-package-locks ,sym)) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))))) + (assert (raises-error? (funcall fun) program-error))) (assert (raises-error? (eval `(locally (declare (disable-package-locks ,sym)) - ,form - (locally (declare (enable-package-locks ,sym)) - ,form))) - package-lock-violation)))) - -;;;; Program-errors from lexical violations -(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))))) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))) + program-error)))) ;;;; See that trace on functions in locked packages doesn't break ;;;; anything. (assert (trace test:function :break t)) +(untrace test:function) ;;;; No bogus violations from defclass with accessors in a locked -;;;; package. Reported by by François-René Rideau. +;;;; 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)))))) + (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)) @@ -466,16 +476,95 @@ ;;;; 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) +(reset-test t) + (defmethod pcl-type-declaration-method-bug ((test:*special* stream)) test:*special*) (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) + +#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) (assert (raises-error? - (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*)) + program-error)) + +;;; Bogus package lock violations from LOOP + +(assert (equal (loop :for *print-base* :from 2 :to 3 :collect *print-base*) + '(2 3))) + +;;; Package lock for DEFMACRO -> DEFUN and vice-versa. +(reset-test t) +(with-test (:name :bug-576637) + (assert (raises-error? (eval `(defun test:macro (x) x)) + sb-ext:package-lock-violation)) + (assert (eq 'test:macro (eval `(test:macro)))) + (assert (raises-error? (eval `(defmacro test:function (x) x)) + sb-ext:package-lock-violation)) + (assert (eq 'test:function (eval `(test:function))))) + +(defpackage :macro-killing-macro-1 + (:use :cl) + (:lock t) + (:export #:to-die-for)) + +(defpackage :macro-killing-macro-2 + (:use :cl :macro-killing-macro-1)) + +(ctu:file-compile + `((in-package :macro-killing-macro-1) + (defmacro to-die-for () + :original)) + :load t) + +(with-test (:name :defmacro-killing-macro) + (ignore-errors + (ctu:file-compile + `((in-package :macro-killing-macro-2) + (defmacro to-die-for () + :replacement)))) + (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for))))) + +(with-test (:name :setf-macro-function-killing-macro) + (ignore-errors + (ctu:file-compile + `((in-package :macro-killing-macro-2) + (eval-when (:compile-toplevel) + (setf (macro-function 'to-die-for) (constantly :replacement2)))))) + (assert (eq :original (macroexpand '(macro-killing-macro-1:to-die-for))))) + +(with-test (:name :compile-time-defun-package-locked) + ;; Make sure compile-time side-effects of DEFUN are protected against. + (let ((inline-lambda (function-lambda-expression #'fill-pointer))) + ;; Make sure it's actually inlined... + (assert inline-lambda) + (assert (eq :ok + (handler-case + (ctu:file-compile `((defun fill-pointer (x) x))) + (sb-ext:symbol-package-locked-error (e) + (when (eq 'fill-pointer + (sb-ext:package-locked-error-symbol e)) + :ok))))) + (assert (equal inline-lambda + (function-lambda-expression #'fill-pointer))))) + +(with-test (:name :compile-time-defclass-package-locked) + ;; Compiling (DEFCLASS FTYPE ...) used to break SBCL, but the package + ;; locks didn't kick in till later. + (assert (eq :ok + (handler-case + (ctu:file-compile `((defclass ftype () ()))) + (sb-ext:symbol-package-locked-error (e) + (when (eq 'ftype (sb-ext:package-locked-error-symbol e)) + :ok))))) + ;; Check for accessor violations as well. + (assert (eq :ok + (handler-case + (ctu:file-compile `((defclass foo () ((ftype :reader ftype))))) + (sb-ext:symbol-package-locked-error (e) + (when (eq 'ftype (sb-ext:package-locked-error-symbol e)) + :ok)))))) ;;; WOOT! Done. -(sb-ext:quit :unix-status 104)