mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
7dbb3dbbf7
See the commenet at SB-COVER:ENABLE-COVERAGE-LOGGING for a brief sketch. This mode of use is not ready for general consumption.
91 lines
3.6 KiB
Common Lisp
91 lines
3.6 KiB
Common Lisp
(defparameter run-tests::*allowed-inputs* :any)
|
|
(require :sb-cover)
|
|
|
|
(defpackage "SB-COVER-TEST"
|
|
(:export
|
|
"*OUTPUT-DIRECTORY*" "*SOURCE-DIRECTORY*"
|
|
"COMPILE-LOAD" "GET-STATES" "REPORT" "REPORT-EXPECT-FAILURE" "SOURCE-PATHNAME"
|
|
"SOURCE-RECORDING-READTABLE")
|
|
(:use "CL"))
|
|
|
|
(defvar sb-cover-test:*output-directory*)
|
|
(defparameter sb-cover-test:*source-directory* (truename #p"../contrib/sb-cover/"))
|
|
|
|
(defun sb-cover-test:source-pathname (x)
|
|
(merge-pathnames (merge-pathnames x (make-pathname :type "lisp")) sb-cover-test:*source-directory*))
|
|
|
|
(defun sb-cover-test:compile-load (x)
|
|
(let ((p (sb-cover-test:source-pathname x)))
|
|
(load (compile-file p :output-file sb-cover-test:*output-directory*))))
|
|
|
|
(defun sb-cover-test:report ()
|
|
(handler-case
|
|
(sb-cover:report sb-cover-test:*output-directory*)
|
|
(warning (condition)
|
|
(error "Unexpected warning: ~A" condition))))
|
|
|
|
(defun sb-cover-test:report-expect-failure ()
|
|
(handler-case
|
|
(progn
|
|
(sb-cover:report sb-cover-test:*output-directory*)
|
|
(error "Should've signaled a warning"))
|
|
(warning ())))
|
|
|
|
(defun sb-cover-test:get-states (x)
|
|
(handler-case
|
|
(progn
|
|
(sb-cover::refresh-coverage-bits)
|
|
(nth-value 1 (sb-cover::compute-file-info (namestring (sb-cover-test:source-pathname x)) :default)))
|
|
(warning (condition)
|
|
(error "Unexpected warning: ~A" condition))))
|
|
|
|
(defun sb-cover-test:source-recording-readtable ()
|
|
(sb-cover::make-source-recording-readtable (copy-readtable nil)
|
|
(list (make-hash-table :test 'eq) 0)))
|
|
|
|
(defglobal *new-code* nil)
|
|
(defun preserve-code (underlying-fun object reason)
|
|
(declare (ignore underlying-fun reason))
|
|
(push object *new-code*)
|
|
object)
|
|
(compile 'preserve-code)
|
|
;; Weak pointers to toplevel forms need to survive the entire test run
|
|
(sb-int:encapsulate 'sb-fasl::possibly-log-new-code 'override #'preserve-code)
|
|
|
|
(with-test (:name :location-codec)
|
|
(dotimes (i 100) (dotimes (j 100)
|
|
(let* ((start i) (end (+ i j)) (packed (sb-cover::pack-pair start end)))
|
|
(multiple-value-bind (first second) (sb-cover::unpack-pair packed)
|
|
(assert (= start first)) (assert (= end second)))))))
|
|
|
|
(with-test (:name :sb-cover)
|
|
(test-util:with-test-directory (sb-cover-test:*output-directory*)
|
|
(load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*))
|
|
(load (merge-pathnames "file-info-tests.lisp" sb-cover-test:*source-directory*))
|
|
(load (merge-pathnames "save-restore-tests.lisp" sb-cover-test:*source-directory*)))
|
|
(assert (> (length *new-code*) 40)))
|
|
|
|
;;; the return values tested here don't actually need to be as
|
|
;;; specific as COMPLEX, ARRAY (etc.): probably ATOM would do (though
|
|
;;; we might as well test for the slightly stronger consistency that
|
|
;;; we happen to have implemented). In case of future conflict,
|
|
;;; probably weaken these tests rather than contort the
|
|
;;; implementation.
|
|
(with-test (:name (:sb-cover read :sharp-c))
|
|
(let ((*readtable* (sb-cover-test:source-recording-readtable)))
|
|
(assert (typep (read-from-string "#c(0 0)") 'complex))
|
|
(assert (typep (read-from-string "#C(0d0 1/2)") 'complex))))
|
|
|
|
(with-test (:name (:sb-cover read :sharp-a))
|
|
(let ((*readtable* (sb-cover-test:source-recording-readtable)))
|
|
(assert (typep (read-from-string "#2A((1 2) (3 4))") 'array))
|
|
(assert (typep (read-from-string "#a(4 base-char . \"abcd\")") 'array))))
|
|
|
|
(with-test (:name :no-redundant-form-paths)
|
|
(dolist (c *new-code*)
|
|
(let ((map (sb-cover::%find-coverage-map c)))
|
|
(when map
|
|
(sb-int:dovector (paths map)
|
|
(let ((x (remove-duplicates paths :test 'equal)))
|
|
(assert (= (length x) (length paths)))))))))
|