X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackage-locks.impure.lisp;h=485f0eab65c2ffd29ef7997bb8fdc6b43836e673;hb=062283b901155792f65775491aea51481c56faaa;hp=f91a32fadc49183c4dea235bf7239351bab35061;hpb=14d9ae2d08892daee9a94da1a050bb6f2ca57dbe;p=sbcl.git diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index f91a32f..485f0ea 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -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) @@ -71,7 +69,7 @@ (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)) @@ -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." @@ -192,10 +191,10 @@ (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 @@ -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,11 +295,17 @@ (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))) @@ -311,72 +316,83 @@ (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)) @@ -398,68 +415,59 @@ 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) + (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)))) + (assert (raises-error? (load fasl) + sb-ext:package-lock-violation)))) (when (probe-file tmp) (delete-file tmp)) (when (probe-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 -;;;; In addition to that, this is also testing for bug 387 -(with-test (: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)))))) + ,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 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)))))) + (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)) @@ -468,15 +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.