(setf (extern-alien "gc_allocate_dirty" char) 1)
(load "test-util.lisp")
(load "assertoid.lisp")
(load "compiler-test-util.lisp")
(defpackage :run-tests
(:use :cl :test-util :sb-ext))
(in-package run-tests)
(load "colorize.lisp")
(defvar *all-failures* nil)
(defvar *break-on-error* nil)
(defvar *report-skipped-tests* nil)
(defvar *explicit-test-files* nil)
(defvar *input-manifest*)
(defvar *allowed-inputs*)
(load "test-funs")
(defun run-all (&aux (start-time (get-internal-real-time)))
(loop :with remainder = (rest *posix-argv*)
:while remainder
:for arg = (pop remainder)
:do (cond
((string= arg "--evaluator-mode")
(let ((mode (pop remainder)))
(cond
((string= mode "interpret")
(setf *test-evaluator-mode* :interpret))
((string= mode "compile")
(setf *test-evaluator-mode* :compile))
(t
(error "~@<Invalid evaluator mode: ~A. Must be one ~
of interpret, compile.~@:>"
mode)))))
((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))
((string= arg "--report-skipped-tests")
(setf *report-skipped-tests* t))
((string= arg "--no-color"))
(t
(push (merge-pathnames (parse-namestring arg)) *explicit-test-files*))))
(setf *explicit-test-files* (nreverse *explicit-test-files*))
(with-open-file (log "test.log" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(pure-runner (pure-load-files) 'load-test log)
(pure-runner (pure-cload-files) 'cload-test log)
(impure-runner (impure-load-files) 'load-test log)
(impure-runner (impure-cload-files) 'cload-test log)
#-win32 (impure-runner (sh-files) 'sh-test log)
(log-file-elapsed-time "GRAND TOTAL" start-time log))
(report)
(sb-ext:exit :code (if (unexpected-failures)
1
104)))
(defun report ()
(terpri)
(format t "Finished running tests.~%")
(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 log-file-elapsed-time (source-file begin-time log)
(let ((end-time (get-internal-real-time)))
(format log "~6d - ~a~%" (- end-time begin-time) source-file)
(force-output log)))
;;; This is a bit of a hack designed to emulate a sandboxed test runner.
;;; For the sandbox to be properly set up to execute each test, it needs
;;; the names of the files that the test will access for reading.
;;; Without a sandbox, we want to fail in the same way that the sandboxed
;;; executor would, so that we can know when 'input-manifest.lisp-expr'
;;; needs to be edited.
;;; I'm not sure of the best way to allow deliberately nonexistent files
;;; here other than by hardcoding the names we expect.
;;; A more pedantic approach might check whether FILENAME definitely is
;;; a file on disk that was not declared. That's getting a bit insane,
;;; because then we'd have to keep track of directory changes, when this is
;;; only a bare minimum of effort to make sure that the manifest stays in
;;; sync with reality for people who run tests in the ordinary way.
;;;
;;; If *allowed-inputs* is :ANY, then we at worst print a note, and don't
;;; signal an error. This was the simplest way I could imagine to get tests
;;; to pass when truenames don't match source file names, as long as declared
;;; input filtering has already happened.
;;; If you're using something like https://bazel.build/ then it provides
;;; the sandboxing, and the program under test shouldn't try to add another layer.
;;; e.g. if you have two worker nodes, one of them is in a file tree which for
;;; purposes of a test contains only the files named "run-tests.lisp" and
;;; "foo.pure.lisp", and the other has only "run-tests.lisp" and "bar.pure.lisp",
;;; - and perhaps they share storage - such that all of the files
;;; are actually links:
;;; run-tests.lisp -> /blah/xyz12431/c984
;;; foo.pure.lisp -> /blah/zyz23431/c134
;;; bar.pure.lisp -> /blah/fr0bbotz/2344
;;; then everything that the code below tries to do to determine acceptability
;;; of filenames in pretty much broken.
(defun check-manifest (filename)
;; We might see:
;; - "data/compile-file-pos.lisp" or
;; - #P"/path/to/sbcl/tests/data/compile-file-pos.lisp"
;; The latter is generally from COMPILE-FILE.
;; For the latter we could compute the pathname relative to this directory.
;; However, for the moment it suffices to just match on the name
;; without its directory components.
(declare (ignorable filename))
#-win32
(labels ((stem-of (thing)
(namestring (make-pathname :name (pathname-name thing)
:type (pathname-type thing))))
(stem= (a b)
(string= (stem-of a) (stem-of b)))
(starts-with-p (string prefix)
(= (mismatch string prefix) (length prefix))))
(unless (eq (pathname-host filename) sb-impl::*physical-host*)
(return-from check-manifest))
(let ((string (namestring filename)))
(when (or (find #\* (stem-of filename)) ; wild
(starts-with-p string "/dev/") ; dev/null and dev/random
(starts-with-p string "/proc/self")
;; Temp files created by test-util's scratch file routine
(starts-with-p (stem-of string) *scratch-file-prefix*)
;; These have been accepted as okay for a while. Test
;; files should never explicitly create files in these
;; directories, but should always use a scratch file.
(starts-with-p string "/tmp/")
(starts-with-p string "/var/tmp/")
(starts-with-p string "/private/var/folders/")
(string= string "exists")
(member (stem-of filename) '("compiler-test-util.lisp"
"a.txt" "b.lisp"
"no-such-file")
:test #'string=)
(string= (pathname-name filename) "i-am-not") ; any extension
(and (boundp '*allowed-inputs*)
(listp *allowed-inputs*)
(find filename *allowed-inputs* :test #'stem=)))
(return-from check-manifest)))
(if (and (boundp '*allowed-inputs*) (eq *allowed-inputs* :any))
(format *error-output* "~&Assumed valid input file: ~S" filename)
(error "Missing input file in manifest: ~S~%" filename))))
(defun pure-runner (files test-fun log)
(unless files
(return-from pure-runner))
(unless (boundp '*input-manifest*)
(with-open-file (manifest "input-manifest.lisp-expr" :if-does-not-exist nil)
(setf *input-manifest*
(if manifest (read manifest) :ignore))))
(format t "// Running pure tests (~a)~%" test-fun)
(let ((*failures* nil)
;; in case somebody corrupts CL-USER's use list, of course
(standard-use-list (package-use-list "CL-USER")))
(dolist (file files)
(format t "// Running ~a in ~a evaluator mode~%"
file *test-evaluator-mode*)
(let* ((actually-pure
(not (or (search ".impure" (namestring file))
(search ".impure-cload" (namestring file)))))
(packages-to-use '("ASSERTOID" "TEST-UTIL"))
(test-package
(if actually-pure
(make-package
(format nil "TEST~36,5,'_R" (random (expt 36 5)))
:use (append packages-to-use standard-use-list))
(find-package "CL-USER"))))
(setq *allowed-inputs*
(if (eq *input-manifest* :ignore)
:any
(append (cdr (assoc (namestring (make-pathname :name (pathname-name file)
:type (pathname-type file)))
*input-manifest* :test #'string=))
(list file))))
(sb-int:encapsulate
'open 'open-guard
(lambda (f filename &rest args &key direction &allow-other-keys)
(when (or (not direction) (eq direction :input))
(check-manifest filename))
(apply f filename args)))
;; We want to ensure that pure tests remain as pure as possible.
;; DEFSTRUCT, DEFCLASS, DEFGENERIC, DEFMETHOD are certainly impure
;; as there is no easy way to eradicate after-effects. Supposing that
;; one did (SETF (FIND-CLASS 'x) NIL) for each classoid type defined in
;; a test, it does not remove from CLASS-DIRECT-SUBCLASSES of the ancestor.
;; We need to disallow all those impure macros by shadowing them
;; and providing no definition.
;; However, parallel execution uses PURE-RUNNER for impure tests,
;; so we need to leave the definitions alone in that case.
;; DEF{constant,fun,macro,parameter,setf,type,var} are generally ok
;; except when DEFfoo defines something too hairy to hang off a symbol.
(cond (actually-pure
(shadow '("DEFSTRUCT" "DEFMETHOD"
;; Hiding IN-PACKAGE is a good preventative measure.
;; There are other ways to do nasty things of course.
;; Deliberately violating a package lock has got to be impure.
"IN-PACKAGE" "WITHOUT-PACKAGE-LOCKS")
test-package)
;; We have pure tests that exercise the DEFCLASS and DEFGENERIC
;; macros to generate macroexpansion-time errors. That's mostly ok.
;; We can trap attempts to use SB-KERNEL::%COMPILER-mumble
;; functions though.
(dolist (symbol '(sb-kernel::%compiler-defclass
sb-pcl::compile-or-load-defgeneric))
(sb-int:encapsulate symbol 'defblah-guard
(lambda (f &rest args)
(if (eq *package* test-package)
(error "Can't call ~S" f)
(apply f args))))))
(t
(use-package packages-to-use test-package)))
(let ((*package* test-package))
(restart-case
(handler-bind ((error (make-error-handler file)))
(let* ((sb-ext:*evaluator-mode* *test-evaluator-mode*)
(*features*
(if (eq sb-ext:*evaluator-mode* :interpret)
(cons :interpreter *features*)
*features*)))
(let ((start (get-internal-real-time)))
(funcall test-fun file)
(log-file-elapsed-time file start log))))
(skip-file ())))
(sb-int:unencapsulate 'open 'open-guard)
(when actually-pure
(dolist (symbol '(sb-pcl::compile-or-load-defgeneric
sb-kernel::%compiler-defclass))
(sb-int:unencapsulate symbol 'defblah-guard))
(delete-package test-package))))
(makunbound '*allowed-inputs*)
;; after all the files are done
(append-failures)))
(defun run-in-child-sbcl (load eval)
(process-exit-code
(sb-ext:run-program
(first *POSIX-ARGV*)
(list "--core" SB-INT:*CORE-STRING*
"--noinform"
"--no-sysinit"
"--no-userinit"
"--noprint"
"--disable-debugger"
"--load" load
"--eval" (write-to-string eval
:right-margin 1000))
:output t
:input t)))
(defun run-impure-in-child-sbcl (test-file test-fun)
(clear-test-status)
(run-in-child-sbcl
"impure-runner"
`(run-tests::run
,(enough-namestring test-file)
',test-fun
,*break-on-failure*
,*break-on-expected-failure*
,*break-on-error*
,(eq *test-evaluator-mode* :interpret))))
(defun impure-runner (files test-fun log)
(when files
(format t "// Running impure tests (~a)~%" test-fun)
(dolist (file files)
(force-output)
(let ((start (get-internal-real-time))
(exit-code (run-impure-in-child-sbcl file test-fun)))
(log-file-elapsed-time file start log)
(if (= exit-code 104)
(with-open-file (stream #.(merge-pathnames "test-status.lisp-expr"
*load-pathname*)
: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)
(push (list :unhandled-error file) *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)))
(defun append-failures (&optional (failures *failures*))
(setf *all-failures* (append failures *all-failures*)))
(defun unexpected-failures ()
(remove-if (lambda (x)
(or (eq (car x) :expected-failure)
(eq (car x) :unexpected-success)
(eq (car x) :skipped-broken)
(eq (car x) :skipped-disabled)))
*all-failures*))
(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
;; If we're in a tree whose non-directories are
;; symlinks, the truenames of those symlinks might
;; not have the same relationships to each other as
;; we need.
:resolve-symlinks nil)))
(defun pure-load-files ()
(filter-test-files "*.pure.lisp"))
(defun pure-cload-files ()
(filter-test-files "*.pure-cload.lisp"))
(defun impure-load-files ()
(filter-test-files "*.impure.lisp"))
(defun impure-cload-files ()
(filter-test-files "*.impure-cload.lisp"))
(defun sh-files ()
(filter-test-files "*.test.sh"))