;;;; 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.
(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)
(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
(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)
(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)
(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."
(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
(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
(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)))
(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)
`(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
;; 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))
))
(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
;;; 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
(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~%")
+(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
(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))
(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))))
+ ,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))))))
+ (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 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*))
+ 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)
projects / sbcl.git / blobdiff