xtmtest-result-body   scheme

(define (xtmtest-result-body call expected-result extra)
  (let ((prefix (if (null? extra) "" (format "~a: " (car extra)))))
    `(let ((evaluation-environment (current-environment))
           (test-name (format "~a ~a" ,prefix ',(if (pair? call) (car call) call))))
       (print-with-colors 'cyan 'default #t (print "xtmtest "))
       (print-with-colors 'black 'cyan #t (print "" test-name ))
       (println)
       (catch (xtmtest-update-test-result test-name ',call 'compile #f #f)
              (let ((result (eval ',call evaluation-environment)))
                (if (equal? ,expected-result result)
                    (xtmtest-update-test-result ',prefix 'correct ',call ,expected-result result)
                    (xtmtest-update-test-result ',prefix 'incorrect ',call ,expected-result result))))))  )