This is a minor optimization and cleanup. It's mainly to reduce the code size
for tests-suite
(which is a concern on Kawa due to annoying JVM limitations).
It mostly makes sense to merge this into the reference implementation to reduce
divergence from the Kawa version.
ChangeLog:
2017-04-09 Per Bothner <p...@bothner.com>
* testing.scm: Some minor performance improvements.
Mainly foucusing on reducing bytecode size. testing.scm: Some minor
performance improvements.
--
--Per Bothner
p...@bothner.com http://per.bothner.com/
diff --git a/gnu/kawa/slib/testing.scm b/gnu/kawa/slib/testing.scm
index d31aaf319..7ffcfd931 100644
--- a/gnu/kawa/slib/testing.scm
+++ b/gnu/kawa/slib/testing.scm
@@ -109,16 +109,16 @@
(srfi-9
(define-syntax %test-record-define
(syntax-rules ()
- ((%test-record-define alloc runner? (name index setter getter) ...)
- (define-record-type test-runner
+ ((%test-record-define tname alloc runner? (name index getter setter) ...)
+ (define-record-type tname
(alloc)
runner?
- (name setter getter) ...)))))
+ (name getter setter) ...)))))
(else
(define %test-runner-cookie (list "test-runner"))
(define-syntax %test-record-define
(syntax-rules ()
- ((%test-record-define alloc runner? (name index getter setter) ...)
+ ((%test-record-define tname alloc runner? (name index getter setter) ...)
(begin
(define (runner? obj)
(and (vector? obj)
@@ -135,7 +135,7 @@
(define (setter runner value)
(vector-set! runner index value)) ...)))))))
-(%test-record-define
+(%test-record-define test-runner
%test-runner-alloc test-runner?
;; Cumulate count of all tests that have passed and were expected to.
(pass-count 1 test-runner-pass-count test-runner-pass-count!)
@@ -242,13 +242,21 @@
(set! %test-runner-factory runner))))))
;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
- (let ((r (test-runner-current)))
- (if (not r)
- (cond-expand
- (srfi-23 (error "test-runner not initialized - test-begin missing?"))
- (else #t)))
- r))
+(cond-expand
+ (kawa
+ (define (test-runner-get) ::test-runner
+ (let ((r (test-runner-current)))
+ (if (not r)
+ (error "test-runner not initialized - test-begin missing?"))
+ r)))
+ (else
+ (define (test-runner-get)
+ (let ((r (test-runner-current)))
+ (if (not r)
+ (cond-expand
+ (srfi-23 (error "test-runner not initialized - test-begin missing?"))
+ (else #t)))
+ r))))
(define (%test-specifier-matches spec runner)
(spec runner))
@@ -528,6 +536,12 @@
(set-cdr! p value)
(test-result-alist! runner (cons (cons pname value) alist)))))
+(define (test-result-actual-value! runner value)
+ (test-result-set! runner 'actual-value value))
+
+(define (test-result-expected-value! runner value)
+ (test-result-set! runner 'expected-value value))
+
(define (test-result-clear runner)
(test-result-alist! runner '()))
@@ -657,9 +671,9 @@
(let ()
(if (%test-on-test-begin r)
(let ((exp expected))
- (test-result-set! r 'expected-value exp)
+ (test-result-expected-value! r exp)
(let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
+ (test-result-actual-value! r res)
(%test-on-test-end r (comp exp res)))))
(%test-report-result)))))
@@ -681,7 +695,7 @@
(if (%test-on-test-begin r)
(let ()
(let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
+ (test-result-actual-value! r res)
(%test-on-test-end r res))))
(%test-report-result)))))
@@ -804,7 +818,7 @@
(%test-on-test-end r
(catch #t
(lambda ()
- (test-result-set! r 'actual-value expr)
+ (test-result-actual-value! r expr)
#f)
(lambda (key . args)
;; TODO: decide how to specify expected
@@ -835,7 +849,7 @@
(%test-on-test-end r
(try-catch
(let ()
- (test-result-set! r 'actual-value expr)
+ (test-result-actual-value! r expr)
#f)
(ex <java.lang.Throwable>
(test-result-set! r 'actual-error ex)
@@ -848,7 +862,7 @@
(%test-on-test-end r
(try-catch
(let ()
- (test-result-set! r 'actual-value expr)
+ (test-result-actual-value! r expr)
#f)
(ex <java.lang.Throwable>
(test-result-set! r 'actual-error ex)
