X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Frun-tests.lisp;h=3d8c3d4eec5f6eec295dfa8b6515376b79d4d822;hb=31f68584d0732dc0d17f379773e5f87f1e5a78ad;hp=f1a046f6e51146d58a2ccd2f36d13c99052f430b;hpb=fb56427f3e946aae6562e7c9cbc4636a754cd754;p=sbcl.git diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index f1a046f..3d8c3d4 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -1,10 +1,5 @@ -#+#.(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)) +(handler-bind (#+win32 (warning #'muffle-warning)) + (require :sb-posix)) (load "test-util.lisp") @@ -15,9 +10,12 @@ (in-package run-tests) +(load "colorize.lisp") + (defvar *all-failures* nil) (defvar *break-on-error* nil) -(defvar *accept-files* nil) +(defvar *report-skipped-tests* nil) +(defvar *explicit-test-files* nil) (defun run-all () (dolist (arg (cdr *posix-argv*)) @@ -26,86 +24,150 @@ (setf test-util:*break-on-failure* t)) ((string= arg "--break-on-expected-failure") (setf test-util:*break-on-expected-failure* t)) + ((string= arg "--report-skipped-tests") + (setf *report-skipped-tests* t)) + ((string= arg "--no-color")) (t - (push (truename (parse-namestring arg)) *accept-files*)))) + (push (truename (parse-namestring arg)) *explicit-test-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) + #-win32 (impure-runner (sh-files) #'sh-test) (report) - (sb-ext:quit :unix-status (if (unexpected-failures) - 1 - 104))) + (sb-ext:exit :code (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 "Unexpected success:")) - (enough-namestring (second fail)) - (third fail)))))) - (t - (format t "All tests succeeded~%")))) + (let ((skipcount 0) + (*print-pretty* nil)) + (cond (*all-failures* + (format t "Status:~%") + (dolist (fail (reverse *all-failures*)) + (cond ((eq (car fail) :unhandled-error) + (output-colored-text (car fail) + " Unhandled Error") + (format t " ~a~%" + (enough-namestring (second fail)))) + ((eq (car fail) :invalid-exit-status) + (output-colored-text (car fail) + " Invalid exit status:") + (format t " ~a~%" + (enough-namestring (second fail)))) + ((eq (car fail) :skipped-disabled) + (when *report-skipped-tests* + (format t " ~20a ~a / ~a~%" + "Skipped (irrelevant):" + (enough-namestring (second fail)) + (third fail))) + (incf skipcount)) + (t + (output-colored-text + (first fail) + (ecase (first fail) + (:expected-failure " Expected failure:") + (:unexpected-failure " Failure:") + (:leftover-thread " Leftover thread (broken):") + (:unexpected-success " Unexpected success:") + (:skipped-broken " Skipped (broken):") + (:skipped-disabled " Skipped (irrelevant):"))) + (format t " ~a / ~a~%" + (enough-namestring (second fail)) + (third fail))))) + (when (> skipcount 0) + (format t " (~a tests skipped for this combination of platform and features)~%" + skipcount))) + (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) + (when files + (format t "// Running pure tests (~a)~%" test-fun) + (let ((*package* (find-package :cl-user)) + (*failures* nil)) + (setup-cl-user) + (dolist (file files) (format t "// Running ~a~%" file) (restart-case (handler-bind ((error (make-error-handler file))) - (funcall test-fun file)) - (skip-file ())))) - (append-failures))) + (eval (funcall test-fun file))) + (skip-file ()))) + (append-failures)))) + +(defun run-in-child-sbcl (load-forms forms) + ;; We used to fork() for POSIX platforms, and use this for Windows. + ;; However, it seems better to use the same solution everywhere. + (process-exit-code + (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn + (sb-ext:run-program + (first *POSIX-ARGV*) + (append + (list "--core" SB-INT:*CORE-STRING* + "--noinform" + "--no-sysinit" + "--no-userinit" + "--noprint" + "--disable-debugger") + (loop for form in (append load-forms forms) + collect "--eval" + collect (write-to-string form))) + :output sb-sys:*stdout* + :input #-win32 devnull #+win32 sb-sys:*stdin*)))) + +(defun run-impure-in-child-sbcl (test-file test-code) + (run-in-child-sbcl + `((load "test-util") + (load "assertoid") + (defpackage :run-tests + (:use :cl :test-util :sb-ext))) + + `((in-package :cl-user) + (use-package :test-util) + (use-package :assertoid) + (setf test-util:*break-on-failure* ,test-util:*break-on-failure*) + (setf test-util:*break-on-expected-failure* + ,test-util:*break-on-expected-failure*) + (let ((file ,test-file) + (*break-on-error* ,run-tests::*break-on-error*)) + (declare (special *break-on-error*)) + (format t "// Running ~a~%" file) + (restart-case + (handler-bind + ((error (lambda (condition) + (push (list :unhandled-error file) + test-util::*failures*) + (cond (*break-on-error* + (test-util:really-invoke-debugger condition)) + (t + (format *error-output* "~&Unhandled ~a: ~a~%" + (type-of condition) condition) + (sb-debug:print-backtrace))) + (invoke-restart 'skip-file)))) + ,test-code) + (skip-file () + (format t ">>>~a<<<~%" test-util::*failures*))) + (test-util:report-test-status) + (sb-ext:exit :code 104))))) (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) + (when files + (format t "// Running impure tests (~a)~%" test-fun) + (let ((*package* (find-package :cl-user))) + (setup-cl-user) + (dolist (file files) (force-output) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (format t "// Running ~a~%" file) - (restart-case - (handler-bind ((error (make-error-handler file))) - (funcall test-fun file)) - (skip-file () - (format t ">>>~a<<<~%" *failures*))) - (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*)))))))))) + (let ((exit-code (run-impure-in-child-sbcl file + (funcall test-fun file)))) + (if (= exit-code 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 make-error-handler (file) (lambda (condition) @@ -115,7 +177,7 @@ (t (format *error-output* "~&Unhandled ~a: ~a~%" (type-of condition) condition) - (sb-debug:backtrace))) + (sb-debug:print-backtrace))) (invoke-restart 'skip-file))) (defun append-failures (&optional (failures *failures*)) @@ -124,7 +186,9 @@ (defun unexpected-failures () (remove-if (lambda (x) (or (eq (car x) :expected-failure) - (eq (car x) :unexpected-success))) + (eq (car x) :unexpected-success) + (eq (car x) :skipped-broken) + (eq (car x) :skipped-disabled))) *all-failures*)) (defun setup-cl-user () @@ -132,40 +196,44 @@ (use-package :assertoid)) (defun load-test (file) - (load 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))))) + `(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)) + `(let ((process (sb-ext:run-program "/bin/sh" + (list (native-namestring ,file)) + :output *error-output*))) + (let ((*failures* nil)) + (test-util:report-test-status)) + (sb-ext:exit :code (process-exit-code process)))) + +(defun filter-test-files (wild-mask) + (if *explicit-test-files* + (loop for file in *explicit-test-files* + when (pathname-match-p file wild-mask) + collect file) + (directory wild-mask))) (defun pure-load-files () - (directory "*.pure.lisp")) + (filter-test-files "*.pure.lisp")) (defun pure-cload-files () - (directory "*.pure-cload.lisp")) + (filter-test-files "*.pure-cload.lisp")) (defun impure-load-files () - (directory "*.impure.lisp")) + (filter-test-files "*.impure.lisp")) (defun impure-cload-files () - (directory "*.impure-cload.lisp")) + (filter-test-files "*.impure-cload.lisp")) (defun sh-files () - (directory "*.test.sh")) + (filter-test-files "*.test.sh"))