method is applicable, and yet matches neither of the method group
qualifier patterns.
-341: PPRINT-LOGICAL-BLOCK / PPRINT-FILL / PPRINT-LINEAR sharing detection.
- (from Paul Dietz' test suite)
-
- CLHS on PPRINT-LINEAR and PPRINT-FILL (and PPRINT-TABULAR, though
- that's slightly different) states that these functions perform
- circular and shared structure detection on their object. Therefore,
-
- a.(let ((*print-circle* t))
- (pprint-linear *standard-output* (let ((x '(a))) (list x x))))
- should print "(#1=(A) #1#)"
-
- b.(let ((*print-circle* t))
- (pprint-linear *standard-output*
- (let ((x (cons nil nil))) (setf (cdr x) x) x)))
- should print "#1=(NIL . #1#)"
-
- (it is likely that the fault lies in PPRINT-LOGICAL-BLOCK, as
- suggested by the suggested implementation of PPRINT-TABULAR)
-
343: MOP:COMPUTE-DISCRIMINATING-FUNCTION overriding causes error
Even the simplest possible overriding of
COMPUTE-DISCRIMINATING-FUNCTION, suggested in the PCL implementation
(assert (typep (funcall f "HOME") '(or string null))))
;;; success
-(quit :unix-status 104)
(assert (= (64-bit-logcount (1- (ash 1 48))) 48))
(assert (= (64-bit-logcount (1- (ash 1 54))) 54))
\f
-(sb-ext:quit :unix-status 104)
(let ((a '`(1 ,@a ,@b ,.c ,.d)))
(let ((*print-circle* t))
(assert (equal (read-from-string (write-to-string a)) a))))
-
-;;; success
-(quit :unix-status 104)
;; except on machines where addressable space is likely to be
;; much bigger than physical memory
(test-big-bit-vectors)
-\f
-;;; success
-(sb-ext:quit :unix-status 104)
(delete-file "bivalent-stream-test.txt")
-(sb-ext:quit :unix-status 104)
(assert (= 26 (alien-funcall foo)))
-(quit :unix-status 104)
(make-instance 'class-with-symbol-initarg slot arg))
(assert (eql (slot-value (make-thing 1) 'slot) 1))
(assert (eql (slot-value (make-other-thing 'slot 2) 'slot) 2))
-\f
-;;; success
-(sb-ext:quit :unix-status 104)
(list 1 1))))))
;;;; success
-(sb-ext:quit :unix-status 104)
(find-class 'some-structure nil))
(eval-when (:load-toplevel)
(assert (typep (find-class 'some-structure) 'class)))
-
-(sb-ext:quit :unix-status 104) ; success
(progv '(*hannu-trap*) '()
(setq *hannu-trap* t))
(assert (not *hannu-trap*))
-
-\f
-(sb-ext:quit :unix-status 104)
(assert (= e-count 4)))))
;;; success
-(quit :unix-status 104)
(assert (not (subtypep 'cons '(cons structure-object number))))
(assert (subtypep '(cons null fixnum) (type-of '(nil 44))))
-
-(sb-ext:quit :unix-status 104) ; success
'(and condition counted-condition)))
;;; success
-(sb-ext:quit :unix-status 104)
'(#+(or x86 x86-64) "bogus stack frame"
#-(or x86 x86-64) "undefined function"))
-#-(or alpha) ; bug 346
;;; Test for "undefined function" (undefined_tramp) working properly.
;;; Try it with and without tail call elimination, since they can have
;;; different effects. (Specifically, if undefined_tramp is incorrect
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(funcall fun)))
- (assert (verify-backtrace
- (lambda () (test #'optimized))
- (list *undefined-function-frame*
- (list '(flet test) #'optimized))))
+ (with-test (:fails-on '(or :alpha)) ; bug 346
+ (assert (verify-backtrace
+ (lambda () (test #'optimized))
+ (list *undefined-function-frame*
+ (list '(flet test) #'optimized)))))
;; bug 353: This test fails at least most of the time for x86/linux
;; ca. 0.8.20.16. -- WHN
- #-(and x86 linux)
- (assert (verify-backtrace
- (lambda () (test #'not-optimized))
- (list *undefined-function-frame*
- (list '(flet not-optimized))
- (list '(flet test) #'not-optimized)))))
-
-#-alpha ; bug 346
+ (with-test (:fails-on '(or (and :x86 :linux) :alpha))
+ (assert (verify-backtrace
+ (lambda () (test #'not-optimized))
+ (list *undefined-function-frame*
+ (list '(flet not-optimized))
+ (list '(flet test) #'not-optimized))))))
+
;;; Division by zero was a common error on PPC. It depended on the
;;; return function either being before INTEGER-/-INTEGER in memory,
;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
(test (fun)
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(funcall fun)))
- (assert (verify-backtrace (lambda () (test #'optimized))
- (list '(/ 42 &rest)
- (list '(flet test) #'optimized))))
- (assert (verify-backtrace (lambda () (test #'not-optimized))
- (list '(/ 42 &rest)
- '((flet not-optimized))
- (list '(flet test) #'not-optimized)))))
-
-#-(or alpha (and x86 linux)) ; bug 61
-(progn
- (defun throw-test ()
- (throw 'no-such-tag t))
- (assert (verify-backtrace #'throw-test '((throw-test)))))
+ (with-test (:fails-on '(or :alpha)) ; bug 346
+ (assert (verify-backtrace (lambda () (test #'optimized))
+ (list '(/ 42 &rest)
+ (list '(flet test) #'optimized)))))
+ (with-test (:fails-on '(or :alpha)) ; bug 346
+ (assert (verify-backtrace (lambda () (test #'not-optimized))
+ (list '(/ 42 &rest)
+ '((flet not-optimized))
+ (list '(flet test) #'not-optimized))))))
+
+(with-test (:fails-on '(or (and :x86 :linux) :alpha))
+ (progn
+ (defun throw-test ()
+ (throw 'no-such-tag t))
+ (assert (verify-backtrace #'throw-test '((throw-test))))))
;;; test entry point handling in backtraces
(defbt 5 (&optional (opt (oops)))
(list opt))
-#-(and x86 linux)
-(macrolet ((with-details (bool &body body)
- `(let ((sb-debug:*show-entry-point-details* ,bool))
- ,@body)))
-
- ;; TL-XEP
- (print :tl-xep)
- (with-details t
- (assert (verify-backtrace #'namestring
- '(((sb-c::tl-xep namestring) 0 ?)))))
- (with-details nil
- (assert (verify-backtrace #'namestring
- '((namestring)))))
-
-
- ;; &MORE-PROCESSOR
- (with-details t
- (assert (verify-backtrace (lambda () (bt.1.1 :key))
- '(((sb-c::&more-processor bt.1.1) &rest))))
- (assert (verify-backtrace (lambda () (bt.1.2 :key))
- '(((sb-c::&more-processor bt.1.2) &rest))))
- (assert (verify-backtrace (lambda () (bt.1.3 :key))
- '(((sb-c::&more-processor bt.1.3) &rest)))))
- (with-details nil
- (assert (verify-backtrace (lambda () (bt.1.1 :key))
- '((bt.1.1 :key))))
- (assert (verify-backtrace (lambda () (bt.1.2 :key))
- '((bt.1.2 &rest))))
- (assert (verify-backtrace (lambda () (bt.1.3 :key))
- '((bt.1.3 &rest)))))
-
- ;; XEP
- (print :xep)
- (with-details t
- (assert (verify-backtrace #'bt.2.1
- '(((sb-c::xep bt.2.1) 0 ?))))
- (assert (verify-backtrace #'bt.2.2
- '(((sb-c::xep bt.2.2) &rest))))
- (assert (verify-backtrace #'bt.2.3
- '(((sb-c::xep bt.2.3) &rest)))))
- (with-details nil
- (assert (verify-backtrace #'bt.2.1
- '((bt.2.1))))
- (assert (verify-backtrace #'bt.2.2
- '((bt.2.2 &rest))))
- (assert (verify-backtrace #'bt.2.3
- '((bt.2.3 &rest)))))
-
- ;; VARARGS-ENTRY
- (print :varargs-entry)
- (with-details t
- (assert (verify-backtrace #'bt.3.1
- '(((sb-c::varargs-entry bt.3.1) :key nil))))
- (assert (verify-backtrace #'bt.3.2
- '(((sb-c::varargs-entry bt.3.2) :key ?))))
- (assert (verify-backtrace #'bt.3.3
- '(((sb-c::varargs-entry bt.3.3) &rest)))))
- (with-details nil
- (assert (verify-backtrace #'bt.3.1
- '((bt.3.1 :key nil))))
- (assert (verify-backtrace #'bt.3.2
- '((bt.3.2 :key ?))))
- (assert (verify-backtrace #'bt.3.3
- '((bt.3.3 &rest)))))
-
- ;; HAIRY-ARG-PROCESSOR
- (print :hairy-args-processor)
- (with-details t
- (assert (verify-backtrace #'bt.4.1
- '(((sb-c::hairy-arg-processor bt.4.1) ?))))
- (assert (verify-backtrace #'bt.4.2
- '(((sb-c::hairy-arg-processor bt.4.2) ?))))
- (assert (verify-backtrace #'bt.4.3
- '(((sb-c::hairy-arg-processor bt.4.3) &rest)))))
- (with-details nil
- (assert (verify-backtrace #'bt.4.1
- '((bt.4.1 ?))))
- (assert (verify-backtrace #'bt.4.2
- '((bt.4.2 ?))))
- (assert (verify-backtrace #'bt.4.3
- '((bt.4.3 &rest)))))
-
- ;; &OPTIONAL-PROCESSOR
- (print :optional-processor)
- (with-details t
- (assert (verify-backtrace #'bt.5.1
- '(((sb-c::&optional-processor bt.5.1)))))
- (assert (verify-backtrace #'bt.5.2
- '(((sb-c::&optional-processor bt.5.2) &rest))))
- (assert (verify-backtrace #'bt.5.3
- '(((sb-c::&optional-processor bt.5.3) &rest)))))
- (with-details nil
- (assert (verify-backtrace #'bt.5.1
- '((bt.5.1))))
- (assert (verify-backtrace #'bt.5.2
- '((bt.5.2 &rest))))
- (assert (verify-backtrace #'bt.5.3
- '((bt.5.3 &rest))))))
+(with-test (:fails-on '(and :x86 :linux))
+ (macrolet ((with-details (bool &body body)
+ `(let ((sb-debug:*show-entry-point-details* ,bool))
+ ,@body)))
+
+ ;; TL-XEP
+ (print :tl-xep)
+ (with-details t
+ (assert (verify-backtrace #'namestring
+ '(((sb-c::tl-xep namestring) 0 ?)))))
+ (with-details nil
+ (assert (verify-backtrace #'namestring
+ '((namestring)))))
+
+
+ ;; &MORE-PROCESSOR
+ (with-details t
+ (assert (verify-backtrace (lambda () (bt.1.1 :key))
+ '(((sb-c::&more-processor bt.1.1) &rest))))
+ (assert (verify-backtrace (lambda () (bt.1.2 :key))
+ '(((sb-c::&more-processor bt.1.2) &rest))))
+ (assert (verify-backtrace (lambda () (bt.1.3 :key))
+ '(((sb-c::&more-processor bt.1.3) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace (lambda () (bt.1.1 :key))
+ '((bt.1.1 :key))))
+ (assert (verify-backtrace (lambda () (bt.1.2 :key))
+ '((bt.1.2 &rest))))
+ (assert (verify-backtrace (lambda () (bt.1.3 :key))
+ '((bt.1.3 &rest)))))
+
+ ;; XEP
+ (print :xep)
+ (with-details t
+ (assert (verify-backtrace #'bt.2.1
+ '(((sb-c::xep bt.2.1) 0 ?))))
+ (assert (verify-backtrace #'bt.2.2
+ '(((sb-c::xep bt.2.2) &rest))))
+ (assert (verify-backtrace #'bt.2.3
+ '(((sb-c::xep bt.2.3) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.2.1
+ '((bt.2.1))))
+ (assert (verify-backtrace #'bt.2.2
+ '((bt.2.2 &rest))))
+ (assert (verify-backtrace #'bt.2.3
+ '((bt.2.3 &rest)))))
+
+ ;; VARARGS-ENTRY
+ (print :varargs-entry)
+ (with-details t
+ (assert (verify-backtrace #'bt.3.1
+ '(((sb-c::varargs-entry bt.3.1) :key nil))))
+ (assert (verify-backtrace #'bt.3.2
+ '(((sb-c::varargs-entry bt.3.2) :key ?))))
+ (assert (verify-backtrace #'bt.3.3
+ '(((sb-c::varargs-entry bt.3.3) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.3.1
+ '((bt.3.1 :key nil))))
+ (assert (verify-backtrace #'bt.3.2
+ '((bt.3.2 :key ?))))
+ (assert (verify-backtrace #'bt.3.3
+ '((bt.3.3 &rest)))))
+
+ ;; HAIRY-ARG-PROCESSOR
+ (print :hairy-args-processor)
+ (with-details t
+ (assert (verify-backtrace #'bt.4.1
+ '(((sb-c::hairy-arg-processor bt.4.1) ?))))
+ (assert (verify-backtrace #'bt.4.2
+ '(((sb-c::hairy-arg-processor bt.4.2) ?))))
+ (assert (verify-backtrace #'bt.4.3
+ '(((sb-c::hairy-arg-processor bt.4.3) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.4.1
+ '((bt.4.1 ?))))
+ (assert (verify-backtrace #'bt.4.2
+ '((bt.4.2 ?))))
+ (assert (verify-backtrace #'bt.4.3
+ '((bt.4.3 &rest)))))
+
+ ;; &OPTIONAL-PROCESSOR
+ (print :optional-processor)
+ (with-details t
+ (assert (verify-backtrace #'bt.5.1
+ '(((sb-c::&optional-processor bt.5.1)))))
+ (assert (verify-backtrace #'bt.5.2
+ '(((sb-c::&optional-processor bt.5.2) &rest))))
+ (assert (verify-backtrace #'bt.5.3
+ '(((sb-c::&optional-processor bt.5.3) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.5.1
+ '((bt.5.1))))
+ (assert (verify-backtrace #'bt.5.2
+ '((bt.5.2 &rest))))
+ (assert (verify-backtrace #'bt.5.3
+ '((bt.5.3 &rest)))))))
;;;; test TRACE
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out)))
-#-(and ppc darwin)
-;;; bug 379
-(let ((out (with-output-to-string (*trace-output*)
- (trace trace-this :encapsulate nil)
- (assert (eq 'ok (trace-this)))
- (untrace))))
- (assert (search "TRACE-THIS" out))
- (assert (search "returned OK" out)))
+(with-test (:fails-on '(and :ppc :darwin))
+ ;;; bug 379
+ (let ((out (with-output-to-string (*trace-output*)
+ (trace trace-this :encapsulate nil)
+ (assert (eq 'ok (trace-this)))
+ (untrace))))
+ (assert (search "TRACE-THIS" out))
+ (assert (search "returned OK" out))))
;;;; test infinite error protection
(loop while (sb-thread:thread-alive-p thread)))
(disable-debugger)
-
-;;; success
-(quit :unix-status 104)
'(funcall #'square x)
nil)))
-(quit :unix-status 104)
;;; success
(format t "~&/returning success~%")
-(quit :unix-status 104)
(assert (typep 1 'key))
(assert (typep 1 'key-singleton))
-(quit :unix-status 104)
(assert (not (eq *base-string* *character-string*)))
(assert (typep *base-string* 'base-string))
(assert (typep *character-string* '(vector character))))
-\f
-(sb-ext:quit :unix-status 104) ; success
(bdowning-2005-iv-16)
\f
-(sb-ext:quit :unix-status 104)
'list)
(coerce o 'list))))))
;;; success
-(sb-ext:quit :unix-status 104)
(eval '(progn (princ ".") (let ((x 42)) t) (princ "."))))))
;;; success
-(sb-ext:quit :unix-status 104)
(assert (= exhaust-count recurse-count *count*)))
;;; OK!
-(quit :unix-status 104)
(delete-file "external-format-test.txt")
#-sb-unicode
-(sb-ext:quit :unix-status 104)
+(progn
+ (test-util:report-test-status)
+ (sb-ext:quit :unix-status 104))
;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
\f
(delete-file "external-format-test.txt")
-(sb-ext:quit :unix-status 104)
(defun new-pu-label-from-pu-labels (array)
(setf (aref (the myarraytype array) 0)
sb-ext:double-float-positive-infinity))
-
-;;; success
-(quit :unix-status 104)
least-positive-double-float))
(assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
(assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum))))
-#-(or darwin) ;; bug 372
-(progn
- (assert (raises-error? (scale-float 1.0 most-positive-fixnum)
- floating-point-overflow))
- (assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
- floating-point-overflow)))
+
+(with-test (:fails-on '(or :darwin)) ;; bug 372
+ (progn
+ (assert (raises-error? (scale-float 1.0 most-positive-fixnum)
+ floating-point-overflow))
+ (assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
+ floating-point-overflow))))
;;; bug found by jsnell when nfroyd tried to implement better LOGAND
;;; type derivation.
(setq gc-happend nil))
(assert (not gc-happend)))
-(sb-ext:quit :unix-status 104)
((eq byte :eof))
(write-byte byte our-bin-to-char-output))))
test-string))))
-\f
-;;;; Voila!
-
-(quit :unix-status 104) ; success
nil))))
;;; success
-(quit :unix-status 104)
|#
;;; success
-(quit :unix-status 104)
(disassemble 'disassemble-closure)
\f
;;;; success
-(sb-ext:quit :unix-status 104)
(assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*)))
(delete-file *tmp-filename*))))
-(quit :unix-status 104)
(function string<)))))
;;; success
-(quit :unix-status 104)
:arg-types (list list vector))
;;; success
-(quit :unix-status 104)
(assert (equalp (list (testgf08 5.0) (testgf08 17))
'((real) #(integer real))))
|#
-
-(sb-ext:quit :unix-status 104)
;;; from mop.tst in clisp's test suite
|#
-
-(sb-ext:quit :unix-status 104)
(defparameter *counter* (make-counter :start 666))
(assert (eq (funcall *counter*) *counter*))
-
-(sb-ext:quit :unix-status 104)
(eval '(make-instance 'person :name t))
-\f
-;;; success
-(sb-ext:quit :unix-status 104)
\ No newline at end of file
(assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra))
\f
;;;; success
-(sb-ext:quit :unix-status 104)
package-lock-violation))
;;; WOOT! Done.
-(sb-ext:quit :unix-status 104)
(package-error (c) (princ c))
(:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args)))
-(sb-ext:quit :unix-status 104)
actual))
;;;; success
-(quit :unix-status 104)
(write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s)))))
\f
;;; success
-(quit :unix-status 104)
(assert (string= (format nil "~@F" 1.23) "+1.23"))
;;; success
-(quit :unix-status 104)
(assert (not (cdr *nil-that-the-compiler-cannot-constant-fold*)))
;;; success
-(quit :unix-status 104)
(assert (eq 'a (read (make-instance 'my-in-stream :last-char nil))))
;;; success
-(quit :unix-status 104)
--- /dev/null
+#+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
+(load (merge-pathnames "../contrib/asdf/asdf.fasl"))
+
+#+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
+(let ((asdf:*central-registry*
+ (cons "../contrib/systems/" asdf:*central-registry*)))
+ (asdf:oos 'asdf:load-op 'sb-posix))
+
+(load "test-util.lisp")
+
+(defpackage :run-tests
+ (:use :cl :test-util :sb-ext))
+
+(load "assertoid.lisp")
+
+(in-package run-tests)
+
+(defvar *all-failures* nil)
+(defvar *break-on-error* nil)
+(defvar *accept-files* nil)
+
+(defun run-all ()
+ (dolist (arg (cdr *posix-argv*))
+ (cond ((string= arg "--break-on-failure")
+ (setf *break-on-error* t)
+ (setf test-util:*break-on-failure* t))
+ ((string= arg "--break-on-expected-failure")
+ (setf test-util:*break-on-expected-failure* t))
+ (t
+ (push (truename (parse-namestring arg)) *accept-files*))))
+ (pure-runner (pure-load-files) #'load-test)
+ (pure-runner (pure-cload-files) #'cload-test)
+ (impure-runner (impure-load-files) #'load-test)
+ (impure-runner (impure-cload-files) #'cload-test)
+ (impure-runner (sh-files) #'sh-test)
+ (report)
+ (sb-ext:quit :unix-status (if (unexpected-failures)
+ 1
+ 104)))
+
+(defun report ()
+ (terpri)
+ (format t "Finished running tests.~%")
+ (cond (*all-failures*
+ (format t "Status:~%")
+ (dolist (fail (reverse *all-failures*))
+ (cond ((eq (car fail) :unhandled-error)
+ (format t " ~20a ~a~%"
+ "Unhandled error"
+ (enough-namestring (second fail))))
+ ((eq (car fail) :invalid-exit-status)
+ (format t " ~20a ~a~%"
+ "Invalid exit status:"
+ (enough-namestring (second fail))))
+ (t
+ (format t " ~20a ~a / ~a~%"
+ (ecase (first fail)
+ (:expected-failure "Expected failure:")
+ (:unexpected-failure "Failure:")
+ (:unexpected-success "Unexcepted success:"))
+ (enough-namestring (second fail))
+ (third fail))))))
+ (t
+ (format t "All tests succeeded~%"))))
+
+(defun pure-runner (files test-fun)
+ (format t "// Running pure tests (~a)~%" test-fun)
+ (let ((*package* (find-package :cl-user))
+ (*failures* nil))
+ (setup-cl-user)
+ (dolist (file files)
+ (when (accept-test-file file)
+ (format t "// Running ~a~%" file)
+ (handler-case
+ (funcall test-fun file)
+ (error (error)
+ (push (list :unhandled-error file)
+ *all-failures*)
+ (when *break-on-error*
+ (test-util:really-invoke-debugger error))))))
+ (append-failures)))
+
+(defun impure-runner (files test-fun)
+ (format t "// Running impure tests (~a)~%" test-fun)
+ (let ((*package* (find-package :cl-user)))
+ (setup-cl-user)
+ (dolist (file files)
+ (when (accept-test-file file)
+ (force-output)
+ (let ((pid (sb-posix:fork)))
+ (cond ((= pid 0)
+ (format t "// Running ~a~%" file)
+ (handler-case
+ (funcall test-fun file)
+ (error (error)
+ (push (list :unhandled-error file) *failures*)
+ (when *break-on-error*
+ (test-util:really-invoke-debugger error))))
+ (report-test-status)
+ (sb-ext:quit :unix-status 104))
+ (t
+ (let ((status (make-array 1 :element-type '(signed-byte 32))))
+ (sb-posix:waitpid pid 0 status)
+ (if (and (sb-posix:wifexited (aref status 0))
+ (= (sb-posix:wexitstatus (aref status 0))
+ 104))
+ (with-open-file (stream "test-status.lisp-expr"
+ :direction :input
+ :if-does-not-exist :error)
+ (append-failures (read stream)))
+ (push (list :invalid-exit-status file)
+ *all-failures*))))))))))
+
+(defun append-failures (&optional (failures *failures*))
+ (setf *all-failures* (append failures *all-failures*)))
+
+(defun unexpected-failures ()
+ (remove-if (lambda (x) (eq (car x) :expected-failure)) *all-failures*))
+
+(defun setup-cl-user ()
+ (use-package :test-util)
+ (use-package :assertoid))
+
+(defun load-test (file)
+ (load file))
+
+(defun cload-test (file)
+ (let ((compile-name (compile-file-pathname file)))
+ (unwind-protect
+ (progn
+ (compile-file file)
+ (load compile-name))
+ (ignore-errors
+ (delete-file compile-name)))))
+
+(defun sh-test (file)
+ ;; What? No SB-POSIX:EXECV?
+ (let ((process (sb-ext:run-program "/bin/sh"
+ (list (namestring file))
+ :output *error-output*)))
+ (sb-ext:quit :unix-status (process-exit-code process))))
+
+(defun accept-test-file (file)
+ (if *accept-files*
+ (find (truename file) *accept-files* :test #'equalp)
+ t))
+
+(defun pure-load-files ()
+ (directory "*.pure.lisp"))
+
+(defun pure-cload-files ()
+ (directory "*.pure-cload.lisp"))
+
+(defun impure-load-files ()
+ (directory "*.impure.lisp"))
+
+(defun impure-cload-files ()
+ (directory "*.impure-cload.lisp"))
+
+(defun sh-files ()
+ (directory "*.test.sh"))
#!/bin/sh
# Run the regression tests in this directory.
+#
+# Usage: run-tests.sh [--break-on-failure] [--break-on-expected-failure] [files]
+# --break-on-failure Break into the debugger when a test fails
+# unexpectedly
+# --break-on-expected-failure Break into the debugger when any test fails
+#
+# If no test files are specified, runs all tests.
# This software is part of the SBCL system. See the README file for
# more information.
# generated relative to `pwd` in the tests/ directory) so that tests
# can chdir before invoking SBCL and still work.
sbclstem=`pwd`/../src/runtime/sbcl
-SBCL="${1:-$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger}"
+SBCL="$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger"
export SBCL
echo /running tests on SBCL=\'$SBCL\'
# more or less like SBCL, but without enough grot removed that appending
# --sysinit, so if you use it in a test, you need to add those
# yourself if you want things to be clean. If many tests start using
# this, we can redo it as a shell function or something so that the
-# magic can be done once and only once.)
+# magic can be done once and only once.). Not used in this file, but
+# exists for the benefit of the *.test.sh files that can be started by
+# run-tests.lisp
SBCL_ALLOWING_CORE=${1:-$sbclstem}
export SBCL_ALLOWING_CORE
echo /with SBCL_ALLOWING_CORE=\'$SBCL_ALLOWING_CORE\'
# successful" path.
tenfour () {
if [ $1 = 104 ]; then
- echo ok
+ echo ok
else
- echo test $2 failed, expected 104 return code, got $1
- exit 1
+ echo test $2 failed, expected 104 return code, got $1
+ exit 1
fi
}
-# *.pure.lisp files are ordinary Lisp code with no side effects,
-# and we can run them all in a single Lisp process.
-echo //running '*.pure.lisp' tests
-echo //i.e. *.pure.lisp
-(
-echo "(progn"
-echo " (progn (format t \"//loading assertoid.lisp~%\") (load \"assertoid.lisp\"))"
-echo " (use-package \"ASSERTOID\")"
-for f in *.pure.lisp; do
- if [ -f $f ]; then
- echo " (progn (format t \"//running $f test~%\") (load \"$f\"))"
- fi
-done
-echo " (sb-ext:quit :unix-status 104)) ; Return status=success."
-) | $SBCL ; tenfour $? "(pure.lisp files)"
-
-# *.impure.lisp files are Lisp code with side effects (e.g. doing
-# DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table).
-# Each one should be LOADed in a separate invocation of Lisp, so
-# that we don't need to worry about them interfering with each
-# other.
-echo //running '*.impure.lisp' tests
-for f in *.impure.lisp; do
- if [ -f $f ]; then
- echo //running $f test
- echo "(load \"$f\")" | $SBCL ; tenfour $? $f
- fi
-done
-
-# *.test.sh files are scripts to test stuff, typically stuff which
-# can't so easily be tested within Lisp itself. A file foo.test.sh
-# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp,
-# or foo.pl.
-echo //running '*.test.sh' tests
-for f in *.test.sh; do
- if [ -f $f ]; then
- echo //running $f test
- sh $f "$SBCL"; tenfour $? $f
- fi
-done
-
-# *.assertoids files contain ASSERTOID statements to test things
-# interpreted and at various compilation levels.
-echo //running '*.assertoids' tests
-for f in *.assertoids; do
- if [ -f $f ]; then
- echo //running $f test
- echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour $? $f
- fi
-done
-
-# *.pure-cload.lisp files want to be compiled, then loaded. They
-# can all be done in the same invocation of Lisp.
-echo //running '*.pure-cload.lisp' tests
-for f in *.pure-cload.lisp; do
- # (Actually here we LOAD each one into a separate invocation
- # of Lisp just because I haven't figured out a concise way
- # to LOAD them all into the same Lisp.)
- if [ -f $f ]; then
- echo //running $f test
- $SBCL <<EOF ; tenfour $? $f
- (compile-file "$f")
- (progn
- (unwind-protect
- (load *)
- (ignore-errors (delete-file (compile-file-pathname "$f"))))
- (sb-ext:quit :unix-status 104))
-EOF
- fi
-done
-
-# *.impure-cload.lisp files want to be compiled, then loaded. They
-# can have side effects, so each one should be done in a separate
-# invocation of Lisp so that they don't interfere.
-echo //running '*.impure-cload.lisp' tests
-for f in *.impure-cload.lisp; do
- if [ -f $f ]; then
- echo //running $f test
- $SBCL <<EOF ; tenfour $? $f
- (compile-file "$f")
- (progn
- (unwind-protect
- (load *)
- (ignore-errors (delete-file (compile-file-pathname "$f"))))
- (sb-ext:quit :unix-status 104))
-EOF
- fi
-done
+$SBCL --eval '(with-compilation-unit () (load "run-tests.lisp"))' \
+ --eval '(run-tests::run-all)' $*
-# (*.before-xc.lisp and *.after-xc.lisp files aren't handled in this
-# script at all. They're tests intended to run in the cross-compiler,
-# so that some functionality can be tested even when cold init doesn't
-# work.)
+tenfour $?
echo '//apparent success (reached end of run-tests.sh normally)'
date
until (= i sb-vm:n-word-bits))
\f
;;; success
-(sb-ext:quit :unix-status 104)
(assert (eq fun (macro-function 'nothing-at-all nil))))
;;; success
-(quit :unix-status 104)
(assert (equal (funcall fn 1 2 3) '(1 2 3))))
;;; success
-(quit :unix-status 104)
saps
(mapcar #'sb-sys:vector-sap vectors)))))
-(quit :unix-status 104)
(loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte))
;;; success
-(quit :unix-status 104)
--- /dev/null
+(defpackage :test-util
+ (:use :cl :sb-ext)
+ (:export #:with-test #:report-test-status #:*failures*
+ #:really-invoke-debugger
+ #:*break-on-failure* #:*break-on-expected-failure*))
+
+(in-package :test-util)
+
+(defvar *test-count* 0)
+(defvar *test-file* nil)
+(defvar *failures* nil)
+(defvar *break-on-failure* nil)
+(defvar *break-on-expected-failure* nil)
+
+(defmacro with-test ((&key fails-on name) &body body)
+ `(handler-case (progn
+ (start-test)
+ ,@body
+ (when (expected-failure-p ,fails-on)
+ (fail-test :unexpected-success ',name nil)))
+ (error (error)
+ (if (expected-failure-p ,fails-on)
+ (fail-test :expected-failure ',name error)
+ (fail-test :unexpected-failure ',name error)))))
+
+(defun report-test-status ()
+ (with-standard-io-syntax
+ (with-open-file (stream "test-status.lisp-expr"
+ :direction :output
+ :if-exists :supersede)
+ (format stream "~s~%" *failures*))))
+
+(defun start-test ()
+ (unless (eq *test-file* *load-pathname*)
+ (setf *test-file* *load-pathname*)
+ (setf *test-count* 0))
+ (incf *test-count*))
+
+(defun fail-test (type test-name condition)
+ (push (list type *test-file* (or test-name *test-count*))
+ *failures*)
+ (when (or (and *break-on-failure*
+ (not (eq type :expected-failure)))
+ *break-on-expected-failure*)
+ (really-invoke-debugger condition)))
+
+(defun expected-failure-p (fails-on)
+ (sb-impl::featurep fails-on))
+
+(defun really-invoke-debugger (condition)
+ (with-simple-restart (continue "Continue")
+ (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
+ (enable-debugger)
+ (invoke-debugger condition))))
;; overall exit status is 0, not 104
(sleep 2)
-(sb-ext:quit :unix-status 104)
(assert-nil-t (subtypep `(not ,t1) `(not ,t2))))
\f
;;; success
-(quit :unix-status 104)
;;; Old PCL hung up on this.
(defmethod #:foo ()
(defun #:bar ()))
-\f
-(quit :unix-status 104)
+\f
\ No newline at end of file
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.4.5"
+"0.9.4.6"
projects / sbcl.git / commitdiff