Apply optimization patch from Per Bothner.

In Per's words:

  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  <[email protected]>

          * testing.scm: Some minor performance improvements.
          Mainly foucusing on reducing bytecode size. testing.scm:
          Some minor performance improvements.

Author: arthurgleckler

testing.scm

@@ -114,16 +114,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)
@@ -140,7 +140,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!)
@@ -247,13 +247,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))
@@ -554,6 +562,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 '()))
 
@@ -683,9 +697,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)))))
 
@@ -707,7 +721,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)))))
 
@@ -830,7 +844,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
@@ -861,7 +875,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)
@@ -874,7 +888,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)