contrib/sb-cover/tests.lisp

   1 (defpackage sb-cover-test (:use :cl :asdf :uiop))
   2
   3 (in-package sb-cover-test)
   4
   5 (defparameter *source-directory*
   6   (system-source-directory :sb-cover))
   7 (defparameter *output-directory*
   8   (apply-output-translations *source-directory*))
   9
  10 (setf *default-pathname-defaults* (translate-logical-pathname *default-pathname-defaults*))
  11
  12 (defun compile-load (x)
  13   (flet ((in-dir (dir type)
  14            (translate-logical-pathname (subpathname dir x :type type))))
  15     (load (compile-file (in-dir *source-directory* "lisp")
  16                         :output-file (in-dir *output-directory* "fasl")))))
  17
  18 (defun report ()
  19   (handler-case
  20       (sb-cover:report *output-directory*)
  21     (warning ()
  22       (error "Unexpected warning"))))
  23
  24 (defun report-expect-failure ()
  25   (handler-case
  26       (progn
  27         (sb-cover:report *output-directory*)
  28         (error "Should've raised a warning"))
  29     (warning ())))
  30
  31
  32 ;;; No instrumentation
  33 (compile-load "test-data-1")
  34 (report-expect-failure)
  35
  36 ;;; Instrument the file, try again -- first with a non-directory pathname
  37
  38 (proclaim '(optimize sb-cover:store-coverage-data))
  39 (compile-load "test-data-1")
  40
  41 (catch 'ok
  42   (handler-case
  43       (sb-cover:report #p"/tmp/foo")
  44     (error ()
  45       (throw 'ok nil)))
  46   (error "REPORT with a non-pathname directory did not signal an error."))
  47
  48 (report)
  49
  50 (assert (probe-file (subpathname *output-directory* "cover-index.html")))
  51
  52 ;;; None of the code was executed
  53 (assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
  54 (assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
  55 (assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
  56 (assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :expression))))
  57
  58 ;;; Call the function again
  59 (test1)
  60 (report)
  61
  62 ;;; And now we should have complete expression coverage
  63 (assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
  64 (assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
  65 (assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
  66 (assert (= (sb-cover::ok-of (getf sb-cover::*counts* :expression))
  67            (sb-cover::all-of (getf sb-cover::*counts* :expression))))
  68
  69 ;;; Reset-coverage clears the instrumentation
  70 (sb-cover:reset-coverage)
  71
  72 (report)
  73
  74 ;;; So none of the code should be marked as executed
  75 (assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
  76 (assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
  77 (assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
  78 (assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :expression))))
  79
  80 ;;; Forget all about that file
  81 (sb-cover:clear-coverage)
  82 (report-expect-failure)
  83
  84 ;;; Another file, with some branches
  85 (compile-load "test-data-2")
  86
  87 (test2 1)
  88 (report)
  89
  90 ;; Complete expression coverage
  91 (assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
  92 (assert (= (sb-cover::ok-of (getf sb-cover::*counts* :expression))
  93            (sb-cover::all-of (getf sb-cover::*counts* :expression))))
  94 ;; Partial branch coverage
  95 (assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
  96 (assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :branch))))
  97 (assert (/= (sb-cover::ok-of (getf sb-cover::*counts* :branch))
  98             (sb-cover::all-of (getf sb-cover::*counts* :branch))))
  99
 100 (test2 0)
 101 (report)
 102
 103 ;; Complete branch coverage
 104 (assert (= (sb-cover::ok-of (getf sb-cover::*counts* :branch))
 105            (sb-cover::all-of (getf sb-cover::*counts* :branch))))
 106
 107 ;; Check for presence of constant coalescing bugs
 108 (compile-load "test-data-3")
 109 (test-2)
 110
 111 ;; Clean up after the tests
 112 (map nil #'delete-file
 113      (directory (merge-pathnames #p"*.html" *output-directory*)))