From: Christophe Rhodes Date: Wed, 11 Sep 2013 11:24:43 +0000 (+0100) Subject: more restrictive test naming X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f7ed7e78e455b9a17b902aa030ce897afbe70d71;p=sbcl.git more restrictive test naming restrict test names to trees of integers and external symbols in CL/KEYWORD/SB- packages. --- diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index e68278c..6637dba 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -204,7 +204,7 @@ :ok))))) ;;; Unused local alien caused a compiler error -(with-test (:name unused-local-alien) +(with-test (:name :unused-local-alien) (let ((fun `(lambda () (sb-alien:with-alien ((alien1923 (array (sb-alien:unsigned 8) 72))) (values))))) @@ -250,7 +250,7 @@ #-win32 ;kludge: This reader conditional masks a bug, but allows the test ;to fail cleanly. (sb-alien:define-alien-routine bug-316075 void (result char :out)) -(with-test (:name bug-316075 :fails-on :win32) +(with-test (:name :bug-316075 :fails-on :win32) #+win32 (error "fail") (handler-bind ((warning #'error)) (compile nil '(lambda () (multiple-value-list (bug-316075)))))) @@ -267,7 +267,7 @@ ((foo (unsigned 32))) foo) -(with-test (:name bug-316325 :skipped-on '(not (or :x86-64 :x86))) +(with-test (:name :bug-316325 :skipped-on '(not (or :x86-64 :x86))) ;; This test works by defining a callback function that provides an ;; identity transform over a full-width machine word, then calling ;; it as if it returned a narrower type and checking to see if any diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index ba823a0..b775bbd 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -225,12 +225,12 @@ (type-error () :good))))) -(with-test (:name (adjust-array multidimensional)) +(with-test (:name (adjust-array :multidimensional)) (let ((ary (make-array '(2 2)))) ;; SBCL used to give multidimensional arrays a bogus fill-pointer (assert (not (array-has-fill-pointer-p (adjust-array ary '(2 2))))))) -(with-test (:name %set-fill-pointer/error) +(with-test (:name :%set-fill-pointer/error) (let ((v (make-array 3 :fill-pointer 0))) (handler-case (progn @@ -253,7 +253,7 @@ (sb-ext::array-storage-vector (make-array 5 :fill-pointer 4))))))) -(with-test (:name invalid-array-index-error) +(with-test (:name :invalid-array-index-error) (let ((array (make-array '(3 3 3)))) (assert (eq :right @@ -289,7 +289,7 @@ (assert (equalp (adjust-array a 2 :initial-element 10) #(5 10))))) -(with-test (:name (make-array-transform-unknown-type :bug-1156095)) +(with-test (:name (:make-array-transform-unknown-type :bug-1156095)) (assert (handler-case (compile nil `(lambda () (make-array '(1 2) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index d08bb70..bb62a68 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -130,7 +130,7 @@ ;;; callbacks with void return values -(with-test (:name void-return) +(with-test (:name :void-return) (sb-alien::alien-lambda void () (values))) diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp index 4da330e..afde50a 100644 --- a/tests/clos-1.impure.lisp +++ b/tests/clos-1.impure.lisp @@ -123,7 +123,7 @@ ;;; Tests the compiler's incremental rejiggering of GF types. (fmakunbound 'foo) -(with-test (:name keywords-supplied-in-methods-ok-1) +(with-test (:name :keywords-supplied-in-methods-ok-1) (assert (null (nth-value @@ -134,7 +134,7 @@ (compile nil '(lambda () (foo (read) :bar 10)))))))) (fmakunbound 'foo) -(with-test (:name keywords-supplied-in-methods-ok-2) +(with-test (:name :keywords-supplied-in-methods-ok-2) (assert (nth-value 1 @@ -149,7 +149,7 @@ ;; parse the tail of the arglist as keywords, so we don't treat the ;; function type as having &KEY in it. (fmakunbound 'foo) -(with-test (:name gf-rest-method-key) +(with-test (:name :gf-rest-method-key) (defgeneric foo (x &rest y)) (defmethod foo ((i integer) &key w) (list i w)) ;; 1.0.20.30 failed here. @@ -161,7 +161,7 @@ ;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be ;; anything, and we don't warn about unrecognized keys. (fmakunbound 'foo) -(with-test (:name gf-allow-other-keys) +(with-test (:name :gf-allow-other-keys) (defgeneric foo (x &key &allow-other-keys)) (defmethod foo ((i integer) &key y z) (list i y z)) (assert @@ -176,7 +176,7 @@ ;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the ;; GF should be construed to have &ALLOW-OTHER-KEYS. (fmakunbound 'foo) -(with-test (:name method-allow-other-keys) +(with-test (:name :method-allow-other-keys) (defgeneric foo (x &key)) (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y)) (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20)))))) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index b368f8c..e16e0cb 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -3,7 +3,7 @@ (defstruct xxx yyy) (macrolet ((test (init op) - `(with-test (:name (:cas :basics ,op)) + `(with-test (:name (:cas :basics ,(intern (symbol-name op) "KEYWORD"))) (let ((x ,init) (y (list 'foo)) (z (list 'bar))) @@ -431,7 +431,7 @@ (assert (eq :ok (cas bar :ok nil))) (assert (not (cas bar nil t))))) -(with-test (:name atomic-push +(with-test (:name :atomic-push :skipped-on '(not :sb-thread)) (let ((store (cons nil nil)) (n 100000)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index adc6a75..7ab3ee5 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1413,7 +1413,7 @@ (defun test-function-983 (x) x) (define-compiler-macro test-function-983 (x) x) -(with-test (:name funcall-compiler-macro) +(with-test (:name :funcall-compiler-macro) (assert (handler-case (and (compile nil diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 1a398d3..2898bcd 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1775,7 +1775,7 @@ (error "bad RANDOM event")))) ;;; 0.8.17.28-sma.1 lost derived type information. -(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc) +(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc) (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c)))) (compile nil '(lambda (x y v) @@ -3091,7 +3091,7 @@ (array-in-bounds-p a 5 2)))))) ;;; optimizing (EXPT -1 INTEGER) -(with-test (:name (expt minus-one integer)) +(with-test (:name (expt -1 integer)) (dolist (x '(-1 -1.0 -1.0d0)) (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x)))))) (assert (not (ctu:find-named-callees fun))) @@ -4479,7 +4479,7 @@ (setf hash (logand most-positive-word (ash hash 5))))))) -(with-test (:name (local-&optional-recursive-inline :bug-1180992)) +(with-test (:name (:local-&optional-recursive-inline :bug-1180992)) (compile nil `(lambda () (labels ((called (&optional a)) @@ -4501,7 +4501,7 @@ ;; be reported as mismatches with the value NIL. Make sure we get ;; a warning, but that it doesn't complain about a constant NIL ... ;; of type FIXNUM. -(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast)) +(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast)) (block nil (handler-bind ((sb-int:type-warning (lambda (c) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index c69015e..33b3861 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -547,7 +547,7 @@ (assert (search "TRACE-THIS" out)) (assert (search "returned OK" out)))) -(with-test (:name (trace-recursive :encapsulate nil) +(with-test (:name (:trace-recursive :encapsulate nil) :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos) :broken-on '(or :darwin (and :x86 :sunos))) (let ((out (with-output-to-string (*trace-output*) @@ -622,7 +622,7 @@ (format t "recursive condition: ~A~%" condition) (force-output) (error "recursive condition: ~A" condition))) -(defun test-inifinite-error-protection () +(defun test-infinite-error-protection () ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used ;; to halt, it produces so much garbage that's hard to suppress that ;; it is tested only once @@ -640,14 +640,14 @@ :normal-exit))))))) (write-line "--END OF H-B-A-B--")) -(with-test (:name infinite-error-protection) +(with-test (:name :infinite-error-protection) (enable-debugger) - (test-inifinite-error-protection)) + (test-infinite-error-protection)) -(with-test (:name (infinite-error-protection :thread) +(with-test (:name (:infinite-error-protection :thread) :skipped-on '(not :sb-thread)) (enable-debugger) - (let ((thread (sb-thread:make-thread #'test-inifinite-error-protection))) + (let ((thread (sb-thread:make-thread #'test-infinite-error-protection))) (loop while (sb-thread:thread-alive-p thread)))) ;; unconditional, in case either previous left it enabled @@ -658,7 +658,7 @@ ;;; Older GENCGC systems had a bug in the pointer validation used by ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to ;;; validate. -(with-test (:name (make-lisp-obj :simple-funs)) +(with-test (:name (:make-lisp-obj :simple-funs)) (sb-sys:without-gcing (assert (eq #'identity (sb-kernel:make-lisp-obj @@ -667,7 +667,7 @@ ;;; Older CHENEYGC systems didn't perform any real pointer validity ;;; checks beyond "is this pointer to somewhere in heap space". -(with-test (:name (make-lisp-obj :pointer-validation)) +(with-test (:name (:make-lisp-obj :pointer-validation)) ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus ;; address, but we also need the GC to not pitch a fit if it sees an ;; object with said bogus address. Thus, construct our known-bogus diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index f676122..00aa376 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -462,12 +462,12 @@ *manyraw*))) (room) (sb-ext:gc)) -(with-test (:name defstruct-raw-slot-gc) +(with-test (:name :defstruct-raw-slot-gc) (check-manyraws *manyraw*)) ;;; try a full GC, too (sb-ext:gc :full t) -(with-test (:name (defstruct-raw-slot-gc :full)) +(with-test (:name (:defstruct-raw-slot-gc :full)) (check-manyraws *manyraw*)) ;;; fasl dumper and loader also have special handling of raw slots, so @@ -488,7 +488,7 @@ ;;; re-read the dumped structures and check them (load "tmp-defstruct.manyraw.fasl") -(with-test (:name (defstruct-raw-slot load)) +(with-test (:name (:defstruct-raw-slot load)) (check-manyraws (dumped-manyraws))) @@ -681,7 +681,7 @@ ;;; of the same class. (Putting this FIXME here, since this is the only ;;; place where they appear together.) -(with-test (:name obsolete-defstruct/print-object) +(with-test (:name :obsolete-defstruct/print-object) (eval '(defstruct born-to-change)) (let ((x (make-born-to-change))) (handler-bind ((error 'continue)) @@ -692,7 +692,7 @@ (sb-pcl::obsolete-structure () :error)))))) -(with-test (:name obsolete-defstruct/typep) +(with-test (:name :obsolete-defstruct/typep) (eval '(defstruct born-to-change-2)) (let ((x (make-born-to-change-2))) (handler-bind ((error 'continue)) @@ -710,7 +710,7 @@ c (a 0d0 :type double-float)) -(with-test (:name raw-slot-equalp) +(with-test (:name :raw-slot-equalp) (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) (make-raw-slot-equalp-bug :a 1d0 :b 2s0))) (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0) @@ -853,7 +853,7 @@ redefinition." ;;; Tests begin. ;; Base case: recklessly-continue. -(with-defstruct-redefinition-test defstruct/recklessly +(with-defstruct-redefinition-test :defstruct/recklessly (((defstruct ctor pred) :class-name redef-test-1 :slots (a)) ((defstruct*) :class-name redef-test-1 :slots (a b))) ((path1 defstruct) @@ -865,7 +865,7 @@ redefinition." (assert-is pred instance))) ;; Base case: continue (i.e., invalidate instances). -(with-defstruct-redefinition-test defstruct/continue +(with-defstruct-redefinition-test :defstruct/continue (((defstruct ctor pred) :class-name redef-test-2 :slots (a)) ((defstruct*) :class-name redef-test-2 :slots (a b))) ((path1 defstruct) @@ -878,7 +878,7 @@ redefinition." ;; Compiling a file with an incompatible defstruct should emit a ;; warning and an error, but the fasl should be loadable. -(with-defstruct-redefinition-test defstruct/compile-file-should-warn +(with-defstruct-redefinition-test :defstruct/compile-file-should-warn (((defstruct) :class-name redef-test-3 :slots (a)) ((defstruct*) :class-name redef-test-3 :slots (a b))) ((path1 defstruct) @@ -889,7 +889,7 @@ redefinition." ;; After compiling a file with an incompatible DEFSTRUCT, load the ;; fasl and ensure that an old instance remains valid. -(with-defstruct-redefinition-test defstruct/compile-file-reckless +(with-defstruct-redefinition-test :defstruct/compile-file-reckless (((defstruct ctor pred) :class-name redef-test-4 :slots (a)) ((defstruct*) :class-name redef-test-4 :slots (a b))) ((path1 defstruct) @@ -902,7 +902,7 @@ redefinition." ;; After compiling a file with an incompatible DEFSTRUCT, load the ;; fasl and ensure that an old instance has become invalid. -(with-defstruct-redefinition-test defstruct/compile-file-continue +(with-defstruct-redefinition-test :defstruct/compile-file-continue (((defstruct ctor pred) :class-name redef-test-5 :slots (a)) ((defstruct*) :class-name redef-test-5 :slots (a b))) ((path1 defstruct) @@ -917,7 +917,7 @@ redefinition." ;; Ensure that recklessly continuing DT(expected)T to instances of ;; subclasses. (This is a case where recklessly continuing is ;; actually dangerous, but we don't care.) -(with-defstruct-redefinition-test defstruct/subclass-reckless +(with-defstruct-redefinition-test :defstruct/subclass-reckless (((defstruct ignore pred1) :class-name redef-test-6 :slots (a)) ((substruct ctor pred2) :class-name redef-test-6-sub :super-name redef-test-6 :slots (z)) @@ -932,7 +932,7 @@ redefinition." (assert-is pred2 instance))) ;; Ensure that continuing invalidates instances of subclasses. -(with-defstruct-redefinition-test defstruct/subclass-continue +(with-defstruct-redefinition-test :defstruct/subclass-continue (((defstruct) :class-name redef-test-7 :slots (a)) ((substruct ctor pred) :class-name redef-test-7-sub :super-name redef-test-7 :slots (z)) @@ -946,7 +946,7 @@ redefinition." (assert-invalid pred instance))) ;; Reclkessly continuing doesn't invalidate instances of subclasses. -(with-defstruct-redefinition-test defstruct/subclass-in-other-file-reckless +(with-defstruct-redefinition-test :defstruct/subclass-in-other-file-reckless (((defstruct ignore pred1) :class-name redef-test-8 :slots (a)) ((substruct ctor pred2) :class-name redef-test-8-sub :super-name redef-test-8 :slots (z)) @@ -966,7 +966,7 @@ redefinition." ;; file, CONTINUE'ing from LOAD of a file containing an incompatible ;; superclass definition leaves the predicates and accessors into the ;; subclass in a bad way until the subclass form is evaluated. -(with-defstruct-redefinition-test defstruct/subclass-in-other-file-continue +(with-defstruct-redefinition-test :defstruct/subclass-in-other-file-continue (((defstruct ignore pred1) :class-name redef-test-9 :slots (a)) ((substruct ctor pred2) :class-name redef-test-9-sub :super-name redef-test-9 :slots (z)) @@ -992,7 +992,7 @@ redefinition." ;; Some other subclass wrinkles have to do with splitting definitions ;; accross files and compiling and loading things in a funny order. (with-defstruct-redefinition-test - defstruct/subclass-in-other-file-funny-operation-order-continue + :defstruct/subclass-in-other-file-funny-operation-order-continue (((defstruct ignore pred1) :class-name redef-test-10 :slots (a)) ((substruct ctor pred2) :class-name redef-test-10-sub :super-name redef-test-10 :slots (z)) @@ -1019,7 +1019,7 @@ redefinition." (assert-invalid pred2 instance))) (with-defstruct-redefinition-test - defstruct/subclass-in-other-file-funny-operation-order-continue + :defstruct/subclass-in-other-file-funny-operation-order-continue (((defstruct ignore pred1) :class-name redef-test-11 :slots (a)) ((substruct ctor pred2) :class-name redef-test-11-sub :super-name redef-test-11 :slots (z)) @@ -1066,7 +1066,7 @@ redefinition." (assert (eq 'string (type-error-expected-type e))) (assert (zerop (type-error-datum e)))))) -(with-test (:name defstruct-copier-typechecks-argument) +(with-test (:name :defstruct-copier-typechecks-argument) (assert (not (raises-error? (copy-person (make-astronaut :name "Neil"))))) (assert (raises-error? (copy-astronaut (make-person :name "Fred"))))) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 392b224..d50708e 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -226,7 +226,7 @@ (with-test (:name :toplevel-declare) (assert (raises-error? (eval '(declare (type pathname *scratch*)))))) -(with-test (:name (eval no-compiler-notes)) +(with-test (:name (eval :no-compiler-notes)) (handler-bind ((sb-ext:compiler-note #'error)) (let ((sb-ext:*evaluator-mode* :compile)) (eval '(let ((x 42)) diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index db4c5fd..0c39817 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -399,7 +399,7 @@ (defun custom-hash-hash (x) (sxhash (custom-hash-key-name x))) (define-hash-table-test custom-hash-test custom-hash-hash) -(with-test (:name define-hash-table-test.1) +(with-test (:name :define-hash-table-test.1) (let ((table (make-hash-table :test 'custom-hash-test))) (setf (gethash (make-custom-hash-key :name "foo") table) :foo) (setf (gethash (make-custom-hash-key :name "bar") table) :bar) @@ -420,7 +420,7 @@ (lambda (x) (logand most-positive-fixnum (reduce #'+ (map 'list #'sxhash (subseq x 0 3)))))) -(with-test (:name define-hash-table-test.2) +(with-test (:name :define-hash-table-test.2) (let ((table (make-hash-table :test 'head-eql))) (setf (gethash #(1 2 3 4) table) :|123|) (setf (gethash '(2 3 4 7) table) :|234|) @@ -438,7 +438,7 @@ (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table))) (assert (eq 'head-eql (hash-table-test table))))) -(with-test (:name make-hash-table/hash-fun) +(with-test (:name :make-hash-table/hash-fun) (let ((table (make-hash-table :test #'= :hash-function (lambda (x) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index ad10e6d..175edce 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -232,7 +232,7 @@ "bar" (incf x y))) -(with-test (:name (documentation closure)) +(with-test (:name (documentation :closure)) (assert (string= (documentation 'docfoo 'function) "bar")) (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz")) (assert (string= (documentation 'docfoo 'function) "baz")) @@ -243,10 +243,10 @@ (assert (not (setf (documentation 'docfoo 'function) nil))) (assert (not (documentation 'docfoo 'function)))) -(with-test (:name (documentation built-in-macro) :skipped-on '(not :sb-doc)) +(with-test (:name (documentation :built-in-macro) :skipped-on '(not :sb-doc)) (assert (documentation 'trace 'function))) -(with-test (:name (documentation built-in-function) :skipped-on '(not :sb-doc)) +(with-test (:name (documentation :built-in-function) :skipped-on '(not :sb-doc)) (assert (documentation 'cons 'function))) (with-test (:name :describe-generic-function-with-assumed-type) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index 0979456..7e43f97 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -90,7 +90,7 @@ :timeout))))) ;;; SLEEP should work with large integers as well -(with-test (:name (sleep pretty-much-forever)) +(with-test (:name (sleep :pretty-much-forever)) (assert (eq :timeout (handler-case (sb-ext:with-timeout 1 diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index 4eda4e4..ee43f50 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -307,10 +307,10 @@ (error () nil))) (ignore-errors (delete-file pathname))))) -(with-test (:name (load "empty.lisp")) +(with-test (:name (load :empty.lisp)) (assert (load-empty-file "lisp"))) -(with-test (:name (load "empty.fasl")) +(with-test (:name (load :empty.fasl)) (assert (not (load-empty-file "fasl")))) (with-test (:name :parallel-fasl-load) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index fbe8e5b..da555f4 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -117,7 +117,7 @@ if a restart was invoked." ;;;; Tests ;;; USE-PACKAGE -(with-test (:name use-package.1) +(with-test (:name :use-package.1) (with-packages (("FOO" (:export "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use))) @@ -127,7 +127,7 @@ if a restart was invoked." (is (eq (sym "BAR" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name use-package.2) +(with-test (:name :use-package.2) (with-packages (("FOO" (:export "SYM")) ("BAZ" (:use) (:intern "SYM"))) (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) @@ -136,7 +136,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name use-package.2a) +(with-test (:name :use-package.2a) (with-packages (("FOO" (:export "SYM")) ("BAZ" (:use) (:intern "SYM"))) (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp) @@ -145,7 +145,7 @@ if a restart was invoked." (is (equal (list (sym "BAZ" "SYM") :internal) (multiple-value-list (sym "BAZ" "SYM"))))))) -(with-test (:name use-package-conflict-set :fails-on :sbcl) +(with-test (:name :use-package-conflict-set :fails-on :sbcl) (with-packages (("FOO" (:export "SYM")) ("QUX" (:export "SYM")) ("BAR" (:intern "SYM")) @@ -167,7 +167,7 @@ if a restart was invoked." conflict-set))))) ;;; EXPORT -(with-test (:name export.1) +(with-test (:name :export.1) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR"))) @@ -177,7 +177,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.1a) +(with-test (:name :export.1a) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR"))) @@ -187,7 +187,7 @@ if a restart was invoked." (is (eq (sym "BAR" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.ensure-exported) +(with-test (:name :export.ensure-exported) (with-packages (("FOO" (:intern "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR") (:IMPORT-FROM "BAR" "SYM"))) @@ -199,7 +199,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.3.intern) +(with-test (:name :export.3.intern) (with-packages (("FOO" (:intern "SYM")) ("BAZ" (:use "FOO") (:intern "SYM"))) (with-name-conflict-resolution ((sym "FOO" "SYM") :restarted restartedp) @@ -208,7 +208,7 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name export.3a.intern) +(with-test (:name :export.3a.intern) (with-packages (("FOO" (:intern "SYM")) ("BAZ" (:use "FOO") (:intern "SYM"))) (with-name-conflict-resolution ((sym "BAZ" "SYM") :restarted restartedp) @@ -218,7 +218,7 @@ if a restart was invoked." (multiple-value-list (sym "BAZ" "SYM"))))))) ;;; IMPORT -(with-test (:name import-nil.1) +(with-test (:name :import-nil.1) (with-packages (("FOO" (:use) (:intern "NIL")) ("BAZ" (:use) (:intern "NIL"))) (with-name-conflict-resolution ((sym "FOO" "NIL") :restarted restartedp) @@ -227,7 +227,7 @@ if a restart was invoked." (is (eq (sym "FOO" "NIL") (sym "BAZ" "NIL")))))) -(with-test (:name import-nil.2) +(with-test (:name :import-nil.2) (with-packages (("BAZ" (:use) (:intern "NIL"))) (with-name-conflict-resolution ('CL:NIL :restarted restartedp) (import '(CL:NIL) "BAZ") @@ -235,7 +235,7 @@ if a restart was invoked." (is (eq 'CL:NIL (sym "BAZ" "NIL")))))) -(with-test (:name import-single-conflict :fails-on :sbcl) +(with-test (:name :import-single-conflict :fails-on :sbcl) (with-packages (("FOO" (:export "NIL")) ("BAR" (:export "NIL")) ("BAZ" (:use))) @@ -253,7 +253,7 @@ if a restart was invoked." ;;; Make sure that resolving a name-conflict in IMPORT doesn't leave ;;; multiple symbols of the same name in the package (this particular ;;; scenario found in 1.0.38.9, but clearly a longstanding issue). -(with-test (:name import-conflict-resolution) +(with-test (:name :import-conflict-resolution) (with-packages (("FOO" (:export "NIL")) ("BAR" (:use))) (with-name-conflict-resolution ((sym "FOO" "NIL")) @@ -262,7 +262,7 @@ if a restart was invoked." (assert (eq sym (sym "FOO" "NIL")))))) ;;; UNINTERN -(with-test (:name unintern.1) +(with-test (:name :unintern.1) (with-packages (("FOO" (:export "SYM")) ("BAR" (:export "SYM")) ("BAZ" (:use "FOO" "BAR") (:shadow "SYM"))) @@ -272,13 +272,13 @@ if a restart was invoked." (is (eq (sym "FOO" "SYM") (sym "BAZ" "SYM")))))) -(with-test (:name unintern.2) +(with-test (:name :unintern.2) (with-packages (("FOO" (:intern "SYM"))) (unintern :sym "FOO") (assert (find-symbol "SYM" "FOO")))) ;;; WITH-PACKAGE-ITERATOR error signalling had problems -(with-test (:name with-package-itarator.error) +(with-test (:name :with-package-iterator.error) (assert (eq :good (handler-case (progn diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index ad0953d..95d246c 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -272,7 +272,7 @@ ;;; bug 350: bignum printing so memory-hungry that heap runs out ;;; -- just don't stall here forever on a slow box -(with-test (:name bug-350) +(with-test (:name :bug-350) (handler-case (with-timeout 10 (print (ash 1 1000000))) diff --git a/tests/profile.impure.lisp b/tests/profile.impure.lisp index 721fdeb..95e4b7f 100644 --- a/tests/profile.impure.lisp +++ b/tests/profile.impure.lisp @@ -80,7 +80,7 @@ (in-package :cl-user) -(with-test (:name (profile threads)) +(with-test (:name (profile :threads)) (profile "PROFILE-TEST") ;; This used to signal an error with threads (let* ((n #+sb-thread 5 #-sb-thread 1) diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp index 01fcace..1db35ca 100644 --- a/tests/reader.impure.lisp +++ b/tests/reader.impure.lisp @@ -125,7 +125,7 @@ (funcall fun) (assert (equal '(:ok) (read-from-string "{:ok)")))) -(with-test (:name bad-recursive-read) +(with-test (:name :bad-recursive-read) ;; This use to signal an unbound-variable error instead. (assert (eq :error (handler-case @@ -134,7 +134,7 @@ (reader-error (e) :error))))) -(with-test (:name standard-readtable-modified) +(with-test (:name :standard-readtable-modified) (macrolet ((test (form &optional op) `(assert (eq :error @@ -166,7 +166,7 @@ (assert (eq (find-package :cl) (test "cl:no-such-sym"))))) ;;; THIS SHOULD BE LAST as it frobs the standard readtable -(with-test (:name set-macro-character-nil) +(with-test (:name :set-macro-character-nil) (handler-bind ((sb-int:standard-readtable-modified-error #'continue)) (let ((fun (lambda (&rest args) 'ok))) ;; NIL means the standard readtable. diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index ab38ed6..fe5fe86 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -371,13 +371,13 @@ size type) #'< :key #'car)))))))) -(with-test (:name &more-elt-index-too-large) +(with-test (:name :&more-elt-index-too-large) (assert (raises-error? (funcall (compile nil '(lambda (&rest args) (declare (optimize safety)) (elt args 0)))) sb-kernel:index-too-large-error))) -(with-test (:name do-sequence-on-literals) +(with-test (:name :do-sequence-on-literals) (assert (= (sequence:dosequence (e #(1 2 3)) (return e)) 1))) diff --git a/tests/setf.impure.lisp b/tests/setf.impure.lisp index b6b7d2f..677318a 100644 --- a/tests/setf.impure.lisp +++ b/tests/setf.impure.lisp @@ -92,7 +92,7 @@ ;;; Not required by the spec, but allowes compiler-macros for SETF-functiosn ;;; to see their constant argument forms. -(with-test (:name constantp-aware-get-setf-expansion) +(with-test (:name :constantp-aware-get-setf-expansion) (multiple-value-bind (temps values stores set get) (get-setf-expansion '(foo 1 2 3)) (assert (not temps)) diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index 6e63ceb..8d0fc37 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -132,7 +132,7 @@ ;;; CLOSING a non-new streams should not delete them, and superseded ;;; files should be restored. -(with-test (:name test-file-for-close-should-not-delete :fails-on :win32) +(with-test (:name :test-file-for-close-should-not-delete :fails-on :win32) (let ((test "test-file-for-close-should-not-delete")) (macrolet ((test-mode (mode) `(progn diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index 526f76b..50b2126 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -324,7 +324,7 @@ ;;; immediately be completely filled for normal files, and that the ;;; buffer-fill routine is responsible for figuring out when we've ;;; reached EOF. -(with-test (:name (stream listen-vs-select) :fails-on :win32) +(with-test (:name (stream :listen-vs-select) :fails-on :win32) (let ((listen-testfile-name "stream.impure.lisp.testqfile") ;; If non-NIL, size (in bytes) of the file that will exercise ;; the LISTEN problem. diff --git a/tests/symbol.pure.lisp b/tests/symbol.pure.lisp index f5f9440..09be75f 100644 --- a/tests/symbol.pure.lisp +++ b/tests/symbol.pure.lisp @@ -20,11 +20,11 @@ (assert (simple-string-p (symbol-name sym))) (print sym (make-broadcast-stream)))) -(with-test (:name (gentemp pprinter)) +(with-test (:name (gentemp :pprinter)) (let* ((*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch 'string (lambda (stream obj) (write-string "BAR-" stream))) (assert (string= "FOO-" (gentemp "FOO-") :end2 4)))) -(with-test (:name (gensym-fixnum-restriction)) +(with-test (:name (gensym :fixnum-restriction)) (gensym (1+ most-positive-fixnum))) diff --git a/tests/test-util.lisp b/tests/test-util.lisp index 40726a4..6c30524 100644 --- a/tests/test-util.lisp +++ b/tests/test-util.lisp @@ -49,6 +49,17 @@ &body body) (let ((block-name (gensym)) #+sb-thread (threads (gensym "THREADS"))) + (flet ((name-ok (x y) + (declare (ignore y)) + (typecase x + (symbol (let ((package (symbol-package x))) + (or (null package) + (eql package (find-package "CL")) + (eql package (find-package "KEYWORD")) + (eql (mismatch "SB-" (package-name package)) 3)))) + (integer t)))) + (unless (tree-equal name name :test #'name-ok) + (error "test name must be all-keywords: ~S" name))) `(progn (start-test) (cond diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 00040dd..7502f53 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -55,7 +55,7 @@ ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS -(with-test (:name without-interrupts+condition-wait +(with-test (:name :without-interrupts+condition-wait :skipped-on '(not :sb-thread) :fails-on '(and :win32 :sb-futex)) (let* ((lock (make-mutex)) @@ -75,7 +75,7 @@ ;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS -(with-test (:name without-interrupts+grab-mutex :skipped-on '(not :sb-thread)) +(with-test (:name :without-interrupts+grab-mutex :skipped-on '(not :sb-thread)) (let* ((lock (make-mutex)) (bar (progn (grab-mutex lock) nil)) (thread (make-thread (lambda () @@ -93,7 +93,7 @@ (assert (eq :aborted (join-thread thread :default :aborted))) (assert bar))) -(with-test (:name parallel-find-class :skipped-on '(not :sb-thread)) +(with-test (:name :parallel-find-class :skipped-on '(not :sb-thread)) (let* ((oops nil) (threads (loop repeat 10 collect (make-thread (lambda () @@ -171,14 +171,14 @@ ;;;; SYMBOL-VALUE-IN-THREAD -(with-test (:name symbol-value-in-thread.1) +(with-test (:name :symbol-value-in-thread.1) (let ((* (cons t t))) (assert (eq * (symbol-value-in-thread '* *current-thread*))) (setf (symbol-value-in-thread '* *current-thread*) 123) (assert (= 123 (symbol-value-in-thread '* *current-thread*))) (assert (= 123 *)))) -(with-test (:name symbol-value-in-thread.2 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.2 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -194,7 +194,7 @@ ;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks, ;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an ;;; interrupted malloc in one thread can apparently block a free in another. -(with-test (:name symbol-value-in-thread.3 +(with-test (:name :symbol-value-in-thread.3 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) @@ -228,7 +228,7 @@ (setf running nil) (join-thread noise))) -(with-test (:name symbol-value-in-thread.4 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.4 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -237,7 +237,7 @@ (signal-semaphore semaphore) (assert (equal '(nil nil) (multiple-value-list (join-thread child)))))) -(with-test (:name symbol-value-in-thread.5 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.5 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (child (make-thread (lambda () @@ -252,7 +252,7 @@ (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread)) (join-thread child))))) -(with-test (:name symbol-value-in-thread.6 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.6 :skipped-on '(not :sb-thread)) (let* ((parent *current-thread*) (semaphore (make-semaphore)) (name (gensym)) @@ -270,7 +270,7 @@ (unless (equal res want) (error "wanted ~S, got ~S" want res))))) -(with-test (:name symbol-value-in-thread.7 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.7 :skipped-on '(not :sb-thread)) (let ((child (make-thread (lambda ()))) (error-occurred nil)) (join-thread child) @@ -284,7 +284,7 @@ (sb-thread::symbol-value-in-thread-error-info e))))) (assert error-occurred))) -(with-test (:name symbol-value-in-thread.8 :skipped-on '(not :sb-thread)) +(with-test (:name :symbol-value-in-thread.8 :skipped-on '(not :sb-thread)) (let ((child (make-thread (lambda ()))) (error-occurred nil)) (join-thread child) @@ -298,7 +298,7 @@ (sb-thread::symbol-value-in-thread-error-info e))))) (assert error-occurred))) -(with-test (:name deadlock-detection.1 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.1 :skipped-on '(not :sb-thread)) (loop repeat 1000 do (flet ((test (ma mb sa sb) @@ -324,7 +324,7 @@ (assert (or (equal '(:deadlock :ok) res) (equal '(:ok :deadlock) res)))))))) -(with-test (:name deadlock-detection.2 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.2 :skipped-on '(not :sb-thread)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) (s1 (sb-thread:make-semaphore :name "S1")) @@ -359,7 +359,7 @@ (assert (stringp err))) (assert (eq :ok (sb-thread:join-thread t1))))) -(with-test (:name deadlock-detection.3 :skipped-on '(not :sb-thread)) +(with-test (:name :deadlock-detection.3 :skipped-on '(not :sb-thread)) (let* ((m1 (sb-thread:make-mutex :name "M1")) (m2 (sb-thread:make-mutex :name "M2")) (s1 (sb-thread:make-semaphore :name "S1"))