: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)))))
#-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))))))
((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
(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
(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
(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)
;;; callbacks with void return values
-(with-test (:name void-return)
+(with-test (:name :void-return)
(sb-alien::alien-lambda void ()
(values)))
\f
;;; 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
(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
;; 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.
;; 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
;; 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))))))
(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)))
(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))
(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
(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)
(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)))
(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))
;; 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)
(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*)
(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
: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
;;; 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
;;; 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
*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
;;; 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)))
\f
;;; 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))
(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))
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)
\f
;;; 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)
(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)
;; 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)
;; 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)
;; 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)
;; 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))
(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))
(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))
;; 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))
;; 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))
(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))
(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")))))
(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))
(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)
(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|)
(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)
"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"))
(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)
: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
(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)
;;;; 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)))
(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)
(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)
(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"))
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")))
(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")))
(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")))
(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)
(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)
(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)
(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")
(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)))
;;; 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"))
(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")))
(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
;;; 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)))
(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)
(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
(reader-error (e)
:error)))))
-(with-test (:name standard-readtable-modified)
+(with-test (:name :standard-readtable-modified)
(macrolet ((test (form &optional op)
`(assert
(eq :error
(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.
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)))
;;; 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))
;;; 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
;;; 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.
(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)))
&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
;;; 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))
;;; 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 ()
(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 ()
;;;; 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 ()
;;; 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))
(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 ()
(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 ()
(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))
(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)
(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)
(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)
(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"))
(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"))
projects / sbcl.git / commitdiff