transcendental-lisp/lisp/unit/unit-tester.lisp

(let ((private-static) (public-static))

  (defun unit-tester-assertions ()
    public-static)

  (setq private-static
    (dlambda
      (:assertion-failed (comparison operand1 operand2)
        (call private-static :print-failure comparison operand1 operand2)
        nil)

      (:print-failure (comparison operand1 operand2)
        (print '==================================================)
        (print (list comparison 'comparison 'failed))
        (print operand1)
        (print operand2)
        (print '--------------------------------------------------))))

  (setq public-static
    (dlambda
      (:assert= (expected actual)
        (call public-static :assert '= expected actual))

      (:assert-equal (expected actual)
        (call public-static :assert 'equal expected actual))

      (:assert-gensym-equal (expected actual)
        (call public-static :assert 'gensym-equal expected actual))

      (:assert (comparison operand1 operand2)
        (if (call comparison operand1 operand2)
          t
          (call private-static :assertion-failed comparison operand1 operand2)))))

  (defun unit-tester (suite)
    (let ((private) (public)
          (suite suite))

      (setq private
        (dlambda
          (:run-suite (suite)
            (if suite
              (cons
                (call private :run-test (car suite))
                (call private :run-suite (cdr suite)))))

          (:run-test (test)
            (if (call test)
              (call private :indicate-success test)
              (call private :indicate-failure test)))

          (:indicate-success (test)
            (print (cons t test))
            t)

          (:indicate-failure (test)
            (print (cons 'f test))
            nil)))

      (setq public
        (dlambda
          (:run ()
            (apply 'and (call private :run-suite suite)))

          (t ()
            (call public :run)))))))