SRFI-64 implementation for Guile 2.0

SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 2955 bytes --]

Hello, world! :)

I'm a newbie of scheme. I'd heard the testing framework SRFI-64 but failed
to use it on Guile 2.0.
After attempt to solve this problem, I made a guile module to pass the test
suite for SRFI-64 by Donovan Kolbly.

--
1. srfi/srfi-64.scm is a SRFI-64 implementation for Guile 2.0.
   srfi-64-test.scm is a test suite for SRFI-64 itself by Donovan Kolbly.

   $ ls -RF
   .:
   README  srfi/  srfi-64-test.scm
   ./srfi:
   srfi-64.scm
   $

2. srfi/srfi-64.scm provide the srfi-64 module for Guile.

   $ guile -L . --use-srfi=64 srfi-64-test.scm
   %%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI
64 - Meta-Test Suite.log")
   # of expected passes      51
   # of expected failures    2
   $ ls -F
   README  SRFI 64 - Meta-Test Suite.log  srfi/  srfi-64-test.scm
   $

3. Somethings were changed:
   1) test-log-to-file is a parameter object.
   2) test-on-test-end-simple and test-on-final-simple have a return value.
   3) and so on.

   Example of log to another file:

   $ guile -L `pwd`
   scheme@(guile-user)> (use-modules (srfi srfi-64))
   scheme@(guile-user)> (test-log-to-file (open-output-file "my-log.log"))
   scheme@(guile-user)> (load "srfi-64-test.scm")
   %%%% Starting test SRFI 64 - Meta-Test Suite
   # of expected passes      51
   # of expected failures    2
   $1 = (51 2 0 0 0)
   scheme@(guile-user)> (close-output-port (test-log-to-file))
   scheme@(guile-user)> ,q
   $

   Contents of log files are same:

   $ ls -F
   README  SRFI 64 - Meta-Test Suite.log  my-log.log  srfi/
 srfi-64-test.scm
   $ diff SRFI\ 64\ -\ Meta-Test\ Suite.log my-log.log
   $ rm SRFI\ 64\ -\ Meta-Test\ Suite.log my-log.log
   $ ls -F
   README  srfi/  srfi-64-test.scm
   $

   Example of not log:

   $ guile -L `pwd`
   scheme@(guile-user)> (use-modules (srfi srfi-64))
   scheme@(guile-user)> (test-log-to-file #f)
   scheme@(guile-user)> (load "srfi-64-test.scm")
   %%%% Starting test SRFI 64 - Meta-Test Suite
   # of expected passes      51
   # of expected failures    2
   $1 = (51 2 0 0 0)
   scheme@(guile-user)> ,q
   $

   The log file were not generated:

   $ ls -F
   README  srfi/  srfi-64-test.scm
   $

   Example in Guile interactive mode:

   $ guile -L `pwd`
   scheme@(guile-user)> (use-modules (srfi srfi-64))
   scheme@(guile-user)> (test-log-to-file #f)
   scheme@(guile-user)> (test-begin "vec-test")
   %%%% Starting test vec-test
   $1 = ("vec-test")
   scheme@(guile-user)> (define v (make-vector 5 99))
   scheme@(guile-user)> (test-assert (vector? v))
   $2 = pass
   scheme@(guile-user)> (test-eqv 99 (vector-ref v 2))
   $3 = pass
   scheme@(guile-user)> (vector-set! v 2 7)
   scheme@(guile-user)> (test-eqv 7 (vector-ref v 2))
   $4 = pass
   scheme@(guile-user)> (test-eqv 8 (vector-ref v 2))
   $5 = fail
   scheme@(guile-user)> (test-end "vec-test")
   # of expected passes      3
   # of unexpected failures  1
   $6 = (3 0 0 1 0)
   scheme@(guile-user)> ,q
   $

[-- Attachment #1.2: Type: text/html, Size: 4409 bytes --]

[-- Attachment #2: srfi-64-guile.tar.gz --]
[-- Type: application/x-gzip, Size: 11846 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 1749 bytes --]

I fixed some bugs and changed test-error to detect using message string
too because of 'misc-error and 'syntax-error.
For example, "^missing or extra expression" and "^string contains #\\\\nul
character" are both 'misc-error.

Example1: just check whether a exception occurs?

  scheme@(guile-user)> (use-modules (srfi srfi-64))
  scheme@(guile-user)> (test-begin "wrong-type-arg")
%%%% Starting test wrong-type-arg  (Writing full log to
"wrong-type-arg.log")
  $1 = ("wrong-type-arg")
  scheme@(guile-user)> (test-error #t (+ "1" 2))
  $2 = pass
  scheme@(guile-user)> (test-end)
  # of expected passes      1
  $3 = (1 0 0 0 0)

Example2: check a specific exception occurs?

  scheme@(guile-user)> (use-modules (srfi srfi-64))
  scheme@(guile-user)> (test-begin "wrong-type-arg")
%%%% Starting test wrong-type-arg  (Writing full log to
"wrong-type-arg.log")
  $1 = ("wrong-type-arg")
  scheme@(guile-user)> (test-error 'wrong-type-arg (+ "1" 2))
  $2 = pass
  scheme@(guile-user)> (test-end)
  # of expected passes      1
  $3 = (1 0 0 0 0)

Example3: check a exception throw a certain message?

  scheme@(guile-user)> (use-modules (srfi srfi-64))
  scheme@(guile-user)> (test-begin "wrong-type-arg")
%%%% Starting test wrong-type-arg  (Writing full log to
"wrong-type-arg.log")
  $1 = ("wrong-type-arg")
scheme@(guile-user)> (test-error "^Wrong type" (+ "1" 2))
  $2 = pass
  scheme@(guile-user)> (test-end)
  # of expected passes      1
  $3 = (1 0 0 0 0)

2012/4/13 Sunjoong Lee <sunjoong@gmail.com>

> Hello, world! :)
>
> I'm a newbie of scheme. I'd heard the testing framework SRFI-64 but failed
> to use it on Guile 2.0.
> After attempt to solve this problem, I made a guile module to pass the
> test suite for SRFI-64 by Donovan Kolbly.
>

[-- Attachment #1.2: Type: text/html, Size: 2788 bytes --]

[-- Attachment #2: srfi-64.scm --]
[-- Type: application/octet-stream, Size: 33679 bytes --]

;; 2006 Per Bothner original.
;; 2012 Sunjoong Lee modified and rewrote to fit Guile 2.0.

;; Copyright (c) 2012 Sunjoong Lee
;; Copyright (c) 2005, 2006 Per Bothner
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(define-module (srfi srfi-64)
  #:use-module (srfi srfi-9)
  #:use-module ((srfi srfi-35)
                #:select (condition-type? condition? condition-has-type?))
  #:use-module ((srfi srfi-39)
                #:select (make-parameter))
  #:use-module ((ice-9 regex)
                #:select (string-match))
  #:export (test-begin
            test-read-eval-string
            test-apply
            test-match-name
            test-match-nth
            test-match-any
            test-match-all
            test-skip
            test-expect-fail
            test-runner-group-path
            test-result-kind
            test-passed?
            test-result-ref
            test-result-set!
            test-result-remove
            test-result-clear
            test-log-to-file            ; not a part of the specification
            ;; Misc test-runner functions
            test-runner?
            test-runner-current
            test-runner-get
            test-runner-simple
            test-runner-null
            test-runner-create
            test-runner-factory
            test-runner-reset
            test-runner-test-name
            ;; test-runner field setter and getter functions
            ;; - see test-runner record definition:
            test-runner-pass-count
            test-runner-pass-count!     ; not a part of the specification
            test-runner-fail-count
            test-runner-fail-count!     ; not a part of the specification
            test-runner-xpass-count
            test-runner-xpass-count!    ; not a part of the specification
            test-runner-xfail-count
            test-runner-xfail-count!    ; not a part of the specification
            test-runner-skip-count
            test-runner-skip-count!     ; not a part of the specification
            test-runner-group-stack
            test-runner-group-stack!    ; not a part of the specification
            test-runner-on-test-begin
            test-runner-on-test-begin!
            test-runner-on-test-end
            test-runner-on-test-end!
            test-runner-on-group-begin
            test-runner-on-group-begin!
            test-runner-on-group-end
            test-runner-on-group-end!
            test-runner-on-final
            test-runner-on-final!
            test-runner-on-bad-count
            test-runner-on-bad-count!
            test-runner-on-bad-end-name
            test-runner-on-bad-end-name!
            test-result-alist
            test-result-alist!          ; not a part of the specification
            test-runner-aux-value
            test-runner-aux-value!
            ;; default/simple call-back functions,
            ;; used in default test-runner,
            ;; but can be called to construct more complex ones.
            test-on-test-begin-simple
            test-on-test-end-simple
            test-on-group-begin-simple
            test-on-group-end-simple
            test-on-bad-count-simple
            test-on-bad-end-name-simple
            test-on-final-simple)
  #:export-syntax (test-end
                   test-group
                   test-group-with-cleanup
                   test-assert
                   test-equal
                   test-eqv
                   test-eq
                   test-approximate
                   test-error
                   test-with-runner))
(cond-expand-provide (current-module) '(srfi-64))

(define-record-type test-runner (%test-runner-alloc) test-runner?
  ;; Cumulate count of all tests that have passed and were expected to.
  (pass-count      test-runner-pass-count      test-runner-pass-count!)
  (fail-count      test-runner-fail-count      test-runner-fail-count!)
  (xpass-count     test-runner-xpass-count     test-runner-xpass-count!)
  (xfail-count     test-runner-xfail-count     test-runner-xfail-count!)
  (skip-count      test-runner-skip-count      test-runner-skip-count!)
  (skip-list       %test-runner-skip-list      %test-runner-skip-list!)
  (fail-list       %test-runner-fail-list      %test-runner-fail-list!)
  ;; Normally #t, except when in a test-apply.
  (run-list        %test-runner-run-list       %test-runner-run-list!)
  (skip-save       %test-runner-skip-save      %test-runner-skip-save!)
  (fail-save       %test-runner-fail-save      %test-runner-fail-save!)
  (group-stack     test-runner-group-stack     test-runner-group-stack!)
  (on-test-begin   test-runner-on-test-begin   test-runner-on-test-begin!)
  (on-test-end     test-runner-on-test-end     test-runner-on-test-end!)
  ;; Call-back when entering a group. Takes (runner suite-name count).
  (on-group-begin  test-runner-on-group-begin  test-runner-on-group-begin!)
  ;; Call-back when leaving a group.
  (on-group-end    test-runner-on-group-end    test-runner-on-group-end!)
  ;; Call-back when leaving the outermost group.
  (on-final        test-runner-on-final        test-runner-on-final!)
  ;; Call-back when expected number of tests was wrong.
  (on-bad-count    test-runner-on-bad-count    test-runner-on-bad-count!)
  ;; Call-back when name in test=end doesn't match test-begin.
  (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
  ;; Cumulate count of all tests that have been done.
  (total-count     %test-runner-total-count    %test-runner-total-count!)
  ;; Stack (list) of (count-at-start . expected-count):
  (count-list      %test-runner-count-list     %test-runner-count-list!)
  (result-alist    test-result-alist           test-result-alist!)
  ;; Field can be used by test-runner for any purpose.
  ;; test-runner-simple uses it for a log file.
  (aux-value       test-runner-aux-value       test-runner-aux-value!))

(define (%source-line runner)
  (let ((result (test-result-alist runner)))
    (let ((file (assq 'source-file result))
          (line (assq 'source-line result)))
      (if line
          (string-append (or file "") ":" (number->string (cdr line)) ": ")
          ""))))

(define (%line form)
  (let ((source-form (datum->syntax form (syntax->datum form)))
        (source-file (assq-ref (syntax-source form) 'filename))
        (source-line (assq-ref (syntax-source form) 'line)))
    (cons (cons #'source-form source-form)
          (if source-file
              (cons (cons #'source-file (basename source-file))
                    (if source-line
                        ;; Line-number begins from 1 not 0.
                        (cons (cons #'source-line (1+ source-line)) '())
                        '()))
              '()))))

(define (test-match-name name)
  (lambda (runner)
    (equal? name (test-runner-test-name runner))))

(define (test-match-nth n . count)
  (let ((i 0) (kount (if (null? count) 1 (car count))))
    (if (< 1 (length count))
        (let ((msg "Usage: (test-match-nth n) or (test-match-nth n count)"))
          (error msg))
        (lambda (runner)
          (set! i (+ i 1))
          (and (>= i n) (< i (+ n kount)))))))

(define test-match-any  'not-yet-defined)
(define test-match-all  'not-yet-defined)
(define test-skip       'not-yet-defined)
(define test-expect-fail'not-yet-defined)
(define %should-execute 'not-yet-defined)
(let ((%any
       (lambda ( . pred-list)
         (lambda (runner)
           (let ((result #f))
             (let loop ((lst pred-list))
               (if (null? lst)
                   result
                   (begin
                     (if ((car lst) runner)
                         (set! result #t))
                     (loop (cdr lst)))))))))
      (%all
       (lambda ( . pred-list)
         (lambda (runner)
           (let ((result #t))
             (let loop ((lst pred-list))
               (if (null? lst)
                   result
                   (begin
                     (if (not ((car lst) runner))
                         (set! result #f))
                     (loop (cdr lst)))))))))
      (%specifier
       (lambda (specifier)
         (cond ((procedure? specifier) specifier)
               ((integer? specifier) (test-match-nth 1 specifier))
               ((string? specifier) (test-match-name specifier))
               (else
                (error "not a valid test specifier"))))))
  (set!
   test-match-any
   (lambda (pred . args)
     (apply %any (%specifier pred) args)))
  (set!
   test-match-all
   (lambda (pred . args)
     (apply %all (%specifier pred) args)))
  (set!
   test-skip
   (lambda (pred . args)
     (let ((runner (test-runner-get)))
       (%test-runner-skip-list! runner
                                (cons (apply
                                       test-match-all (%specifier pred) args)
                                      (%test-runner-skip-list runner))))))
  (set!
   test-expect-fail
   (lambda (pred . args)
     (let ((runner (test-runner-get)))
       (%test-runner-fail-list! runner
                                (cons (apply
                                       test-match-all (%specifier pred) args)
                                      (%test-runner-fail-list runner))))))
  (set!
   ;; Returns #f, #t, or 'xfail.
   %should-execute
   (lambda (runner)
     (let ((run-list (%test-runner-run-list runner)))
       (cond ((or (not (or (eqv? run-list #t)
                           ((apply %any run-list) runner)))
                  ((apply %any (%test-runner-skip-list runner)) runner))
              (test-result-set! runner 'result-kind 'skip)
              #f)
             (((apply %any (%test-runner-fail-list runner)) runner)
              (test-result-set! runner 'result-kind 'xfail)
              'xfail)
             (else #t))))))

(define (test-result-ref runner pname . default)
  (let ((p (assq pname (test-result-alist runner))))
    (cond ((< 1 (length default))
           (let ((msg (string-append
                       "Usage: (test-result-ref runner pname) "
                       "or (test-result-ref runner pname default)")))
             (error msg)))
          (p (cdr p))
          ((not (null? default)) (car default))
          (else #f))))

(define (test-result-set! runner pname value)
  (let ((alist (test-result-alist runner)))
    (let ((p (assq pname alist)))
      (if p
          (set-cdr! p value)
          (test-result-alist! runner (cons (cons pname value) alist))))))

(define (test-result-remove runner pname)
  (let ((alist (test-result-alist runner)))
    (let ((p (assq pname alist)))
      (if p
          (test-result-alist! runner (let loop ((r alist))
                                       (if (eq? r p)
                                           (cdr r)
                                           (cons (car r) (loop (cdr r))))))))))

(define (test-result-clear runner)
  (test-result-alist! runner '()))

(define (test-runner-test-name runner)
  (test-result-ref runner 'test-name ""))

(define (test-runner-group-path runner)
  (reverse (test-runner-group-stack runner)))

(define (test-runner-reset runner)
  (test-runner-pass-count!   runner 0)
  (test-runner-fail-count!   runner 0)
  (test-runner-xpass-count!  runner 0)
  (test-runner-xfail-count!  runner 0)
  (test-runner-skip-count!   runner 0)
  (%test-runner-total-count! runner 0)
  (%test-runner-count-list!  runner '())
  (%test-runner-run-list!    runner #t)
  (%test-runner-skip-list!   runner '())
  (%test-runner-fail-list!   runner '())
  (%test-runner-skip-save!   runner '())
  (%test-runner-fail-save!   runner '())
  (test-runner-group-stack!  runner '()))

;; Not part of the specification.  FIXME
;; Controls whether a log file is generated.
(define test-log-to-file (make-parameter #t))

(define test-on-test-begin-simple 'not-yet-defined)
(define test-on-test-end-simple   'not-yet-defined)
(let ((%display (lambda (pair port)
                  (display "  " port)
                  (display (car pair) port)
                  (display ": " port)
                  (write (cdr pair) port)
                  (newline port))))
  (set!
   test-on-test-begin-simple
   (lambda (runner)
     (let ((log (test-runner-aux-value runner)))
       (if (output-port? log)
           (let ((results (test-result-alist runner)))
             (let ((file (assq 'source-file results))
                   (line (assq 'source-line results))
                   (form (assq 'source-form results))
                   (name (assq 'test-name   results)))
               (display "Test begin:" log)
               (newline log)
               (if name (%display name log))
               (if file (%display file log))
               (if line (%display line log))
               (if form (%display form log))))))))
  (set!
   test-on-test-end-simple
   (lambda (runner)
     (let ((log (test-runner-aux-value runner))
           (kind (test-result-ref runner 'result-kind)))
       (if (output-port? log)
           (begin
             (display "Test end:" log)
             (newline log)
             (let loop ((alist (test-result-alist runner)))
               (if (pair? alist)
                   (let ((pair (car alist)))
                     ;; Write out properties not written out by on-test-begin.
                     (if (not
                          (memq
                           (car pair)
                           '(test-name source-file source-line source-form)))
                         (%display pair log))
                     (loop (cdr alist)))))))
       (if (memq kind '(fail xpass))
           (let ((results (test-result-alist runner)))
             (let ((source-file (assq 'source-file results))
                   (source-line (assq 'source-line results))
                   (test-name   (assq 'test-name   results)))
               (if (or source-file source-line)
                   (begin
                     (if source-file (display (cdr source-file)))
                     (display ":")
                     (if source-line (display (cdr source-line)))
                     (display ": ")
                     (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
                     (if test-name
                         (begin (display " ") (display (cdr test-name))))
                     (newline))))))
       kind))))

(define (test-on-group-begin-simple runner suite-name count)
  (if (null? (test-runner-group-stack runner))
      (begin
        (display "%%%% Starting test ")
        (display suite-name)
        (let ((log-file (if (procedure? test-log-to-file)
                            (test-log-to-file)
                            test-log-to-file)))
          (if log-file
              (begin
                (if (not (output-port? log-file))
                    (let ((log-file-name (if (string? test-log-to-file)
                                             test-log-to-file
                                             (string-append
                                              suite-name ".log"))))
                      (set! log-file (open-output-file log-file-name))
                      (display "  (Writing full log to \"")
                      (display log-file-name)
                      (display "\")")))
                (test-runner-aux-value! runner log-file)
                (display "%%%% Starting test " log-file)
                (display suite-name log-file)
                (newline log-file))))
        (newline)))
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
        (begin
          (display "Group begin: " log)
          (display suite-name log)
          (newline log)))))

(define (test-on-group-end-simple runner)
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
        (begin
          (display "Group end: " log)
          (display (car (test-runner-group-stack runner)) log)
          (newline log)))))

(define (test-on-final-simple runner)
  (let ((log (test-runner-aux-value runner))
        (pass-count (test-runner-pass-count runner))
        (xfail-count (test-runner-xfail-count runner))
        (xpass-count (test-runner-xpass-count runner))
        (fail-count (test-runner-fail-count runner))
        (skip-count (test-runner-skip-count runner)))
    (let ((%display
           (lambda (runner port)
             (let ((%display-if
                    (lambda (value label port)
                      (if (> value 0)
                          (begin
                            (display label port)
                            (display value port)
                            (newline port))))))
               (%display-if pass-count  "# of expected passes      " port)
               (%display-if xfail-count "# of expected failures    " port)
               (%display-if xpass-count "# of unexpected successes " port)
               (%display-if fail-count  "# of unexpected failures  " port)
               (%display-if skip-count  "# of skipped tests        " port)))))
      (if (output-port? log) (%display runner log))
      (%display runner (current-output-port))
      (list pass-count xfail-count xpass-count fail-count skip-count))))

(define (test-on-bad-count-simple runner count expected-count)
  (let ((log (test-runner-aux-value runner))
        (%display
         (lambda (count expected-count port)
           (display "*** Total number of tests was " port)
           (display count port)
           (display " but should be " port)
           (display expected-count port)
           (display ". ***" port)
           (display
            "*** Discrepancy indicates testsuite error or exceptions. ***" port)
           (newline port))))
    (if (output-port? log)
        (%display count expected-count log))
    (%display count expected-count (current-output-port))))

(define (test-on-bad-end-name-simple runner begin-name end-name)
  (let ((msg (string-append
              (%source-line runner) "test-end " begin-name
              " does not match test-begin " end-name)))
    (error msg)))

(define test-runner-current (make-parameter #f))
;; A safer wrapper to test-runner-current.
(define (test-runner-get)
  (let ((runner (test-runner-current)))
    (if (not runner)
        (error "test-runner not initialized - test-begin missing?"))
    runner))

(define (test-runner-simple)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-test-begin! runner test-on-test-begin-simple)
    (test-runner-on-test-end! runner test-on-test-end-simple)
    (test-runner-on-group-begin! runner test-on-group-begin-simple)
    (test-runner-on-group-end! runner test-on-group-end-simple)
    (test-runner-on-final! runner test-on-final-simple)
    (test-runner-on-bad-count! runner test-on-bad-count-simple)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))

(define (test-runner-null)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-test-begin! runner (lambda (runner) #f))
    (test-runner-on-test-end! runner (lambda (runner) #f))
    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
    (test-runner-on-group-end! runner (lambda (runner) #f))
    (test-runner-on-final! runner (lambda (runner) #f))
    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
    runner))

(define test-runner-factory (make-parameter test-runner-simple))
(define (test-runner-create)
  ((test-runner-factory)))

(define (test-result-kind . rest)
  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
    (test-result-ref runner 'result-kind)))

(define (test-passed? . rest)
  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
    (memq (test-result-ref runner 'result-kind) '(pass xpass))))

(define-syntax test-with-runner
  (syntax-rules ()
    ((test-with-runner runner form ...)
     (let ((saved-runner (test-runner-current)))
       (dynamic-wind
           (lambda () (test-runner-current runner))
           (lambda () form ...)
           (lambda () (test-runner-current saved-runner)))))))

(define (test-apply first . rest)
  (if (test-runner? first)
      (test-with-runner first (apply test-apply rest))
      (let ((runner (test-runner-current)))
        (if runner
            (let ((run-list (%test-runner-run-list runner)))
              (cond ((null? rest)
                     (%test-runner-run-list! runner (reverse! run-list))
                     (first))           ; actually apply procedure thunk
                    (else
                     (%test-runner-run-list!
                      runner
                      (if (eq? run-list #t) (list first) (cons first run-list)))
                     (apply test-apply rest)
                     (%test-runner-run-list! runner run-list))))
            (let ((runner (test-runner-create)))
              (test-with-runner runner (apply test-apply first rest))
              ((test-runner-on-final runner) runner))))))

(define (test-begin suite-name . count)
  (if (not (test-runner-current)) (test-runner-current (test-runner-create)))
  (if (< 1 (length count))
      (let ((msg  (string-append
                   "Usage: (test-begin suite-name) "
                  "or (test-begin suite-name count)")))
        (error msg)))
  (let ((runner (test-runner-current))
        (kount (if (null? count) #f (car count))))
    ((test-runner-on-group-begin runner) runner suite-name kount)
    (%test-runner-skip-save! runner
                             (cons (%test-runner-skip-list runner)
                                   (%test-runner-skip-save runner)))
    (%test-runner-fail-save! runner
                             (cons (%test-runner-fail-list runner)
                                   (%test-runner-fail-save runner)))
    (%test-runner-count-list! runner
                              (cons (cons (%test-runner-total-count runner)
                                          kount)
                                    (%test-runner-count-list runner)))
    (test-runner-group-stack! runner
                              (cons suite-name
                                    (test-runner-group-stack runner)))))

(define (%test-end suite-name line)
  (let ((runner (test-runner-get)))
    (test-result-alist! runner line)
    (let ((groups (test-runner-group-stack runner))
          (count-list (%test-runner-count-list runner)))
      (if (null? groups)
          (let ((msg (string-append
                      (%source-line runner) "test-end not in a group")))
            (error msg)))
      (if (and suite-name (not (equal? suite-name (car groups))))
          ((test-runner-on-bad-end-name runner) runner suite-name (car groups)))
      (let ((expected-count (cdar count-list))
            (saved-count (caar count-list)))
        (let ((group-count (- (%test-runner-total-count runner) saved-count)))
          (if (and expected-count (not (= expected-count group-count)))
              ((test-runner-on-bad-count runner) runner
                                                 group-count expected-count))
          ((test-runner-on-group-end runner) runner)
          (test-runner-group-stack! runner
                                    (cdr (test-runner-group-stack runner)))
          (%test-runner-skip-list!  runner
                                    (car (%test-runner-skip-save runner)))
          (%test-runner-skip-save!  runner
                                    (cdr (%test-runner-skip-save runner)))
          (%test-runner-fail-list!  runner
                                    (car (%test-runner-fail-save runner)))
          (%test-runner-fail-save!  runner
                                    (cdr (%test-runner-fail-save runner)))
          (%test-runner-count-list! runner (cdr count-list))
          (if (null? (test-runner-group-stack runner))
              ((test-runner-on-final runner) runner)))))))

(define %test-assert 'not-yet-defined)
(define %test-comp   'not-yet-defined)
(define %test-error  'not-yet-defined)
(let ((%begin
       (lambda (runner)
         (%should-execute runner)
         ((test-runner-on-test-begin runner) runner)
         (not (eq? 'skip (test-result-ref runner 'result-kind)))))
      (%end
       (lambda (runner result)
         (test-result-set! runner
                           'result-kind
                           (if (eq? (test-result-ref runner 'result-kind)
                                    'xfail)
                               (if result 'xpass 'xfail)
                               (if result 'pass 'fail)))))
      (%report
       (lambda (runner kind)
         (case kind
           ((pass)
            (test-runner-pass-count! runner
                                     (1+ (test-runner-pass-count runner))))
           ((fail)
            (test-runner-fail-count! runner
                                     (1+ (test-runner-fail-count runner))))
           ((xpass)
            (test-runner-xpass-count! runner
                                      (1+ (test-runner-xpass-count runner))))
           ((xfail)
            (test-runner-xfail-count! runner
                                      (1+ (test-runner-xfail-count runner))))
           (else
            (test-runner-skip-count! runner
                                     (1+ (test-runner-skip-count runner)))))
         (%test-runner-total-count! runner
                                    (1+ (%test-runner-total-count runner)))
         ((test-runner-on-test-end runner) runner)))
      (%exception
       (lambda (etype excpt)
         (let ((key (car excpt)))
           (cond ((symbol? etype) (equal? etype key))
                 ((string? etype)
                  (if (< 2 (length excpt))
                      (let ((message (caddr excpt)))
                        (cond ((string-match etype message) #t)
                              ((< 3 (length excpt))
                               (string-match
                                etype
                                (apply simple-format #f message (cadddr excpt))))
                              (else #f)))
                      #f))
                 ((condition-type? etype)
                  (and (condition? key)
                       (condition-has-type? key etype)))
                 ((procedure? etype) (etype excpt))
                 (else #t))))))
  (set!
   %test-assert
   (lambda (eval-pair line)
     (let ((runner (test-runner-get))
           (value  (car eval-pair))
           (excpt  (cdr eval-pair)))
       (test-result-alist! runner line)
       (if (%begin runner)
           (if excpt
               (begin
                 (test-result-set! runner 'actual-error excpt)
                 (%end runner #f))
               (begin
                 (test-result-set! runner 'actual-value value)
                 (%end runner value))))
       (%report runner (test-result-ref runner 'result-kind)))))
  (set!
   %test-comp
   (lambda (pred-or-error expected eval-pair line)
     (let ((runner (test-runner-get))
           (value  (car eval-pair))
           (excpt  (cdr eval-pair)))
       (test-result-alist! runner line)
       (if (%begin runner)
           (begin
             (test-result-set! runner 'expected-value expected)
             (if excpt
                 (begin
                   (test-result-set! runner 'actual-error excpt)
                   (%end runner #f))
                 (begin
                   (test-result-set! runner 'actual-value value)
                   (%end runner (if (procedure? pred-or-error)
                                    (pred-or-error expected value)
                                    (and (>= value
                                             (- expected pred-or-error))
                                         (<= value
                                             (+ expected pred-or-error)))))))))
       (%report runner (test-result-ref runner 'result-kind)))))
  (set!
   %test-error
   (lambda (etype eval-pair line)
     (let ((runner (test-runner-get))
           (value  (car eval-pair))
           (excpt  (cdr eval-pair)))
       (test-result-alist! runner line)
       (if (%begin runner)
           (begin
             (test-result-set! runner 'expected-error etype)
             (if excpt
                 (begin
                   (test-result-set! runner 'actual-error excpt)
                   (%end runner (%exception etype excpt)))
                 (begin
                   (test-result-set! runner 'actual-value value)
                   (%end runner #f)))))
       (%report runner (test-result-ref runner 'result-kind))))))

(define (test-read-eval-string string)
  (let ((port (open-input-string string)))
    (let ((form (read port)))
      (if (eof-object? (read-char port))
          (primitive-eval form)
          (error "(not at eof)")))))

(define-syntax test-end
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_) line)
       (syntax (%test-end #f line)))
      (((_ suite-name) line)
       (syntax (%test-end suite-name line))))))

(define-syntax test-group
  (syntax-rules ()
    ((test-group suite-name . body)
     (let ((runner (test-runner-current)))
       ;; Ideally should also set line-number, if available.
       (test-result-alist! runner (list (cons 'test-name suite-name)))
       (if (%should-execute runner)
           (dynamic-wind
               (lambda () (test-begin suite-name))
               (lambda () . body)
               (lambda () (test-end  suite-name))))))))

(define-syntax test-group-with-cleanup
  (syntax-rules ()
    ((test-group-with-cleanup suite-name form cleanup-form)
     (test-group suite-name
                 (dynamic-wind
                     (lambda () #f)
                     (lambda () form)
                     (lambda () cleanup-form))))
    ((test-group-with-cleanup suite-name cleanup-form)
     (test-group-with-cleanup suite-name #f cleanup-form))
    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))

(define-syntax %eval-pair
  (syntax-rules ()
    ((_ expr)
     (let ((value #f) (excpt #f))
       (begin
         (set! value (catch #t
                            (lambda () expr)
                            (lambda ( . exc) (set! excpt exc))))
             (cons value excpt))))))

(define-syntax test-assert
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname expr) line)
       (syntax
        (%test-assert (%eval-pair expr) (cons (cons 'test-name tname) line))))
      (((_ expr) line)
       (syntax (%test-assert (%eval-pair expr) line))))))

(define-syntax test-equal
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname expected expr) line)
       (syntax
        (%test-comp equal? expected (%eval-pair expr)
                    (cons (cons 'test-name tname) line))))
      (((_ expected expr) line)
       (syntax (%test-comp equal? expected (%eval-pair expr) line))))))

(define-syntax test-eqv
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname expected expr) line)
       (syntax
        (%test-comp eqv? expected (%eval-pair expr)
                    (cons (cons 'test-name tname) line))))
      (((_ expected expr) line)
       (syntax (%test-comp eqv? expected (%eval-pair expr) line))))))

(define-syntax test-eq
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname expected expr) line)
       (syntax
        (%test-comp eq? expected (%eval-pair expr)
                    (cons (cons 'test-name tname) line))))
      (((_ expected expr) line)
       (syntax (%test-comp eq? expected (%eval-pair expr) line))))))

(define-syntax test-approximate
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname expected expr err) line)
       (syntax
        (%test-comp err expected (%eval-pair expr)
                    (cons (cons 'test-name tname) line))))
      (((_ expected expr err) line)
       (syntax (%test-comp err expected (%eval-pair expr) line))))))

(define-syntax test-error
  (lambda (x)
    (syntax-case (list x (list (syntax quote) (%line x))) ()
      (((_ tname etype expr) line)
       (syntax
        (%test-error etype (%eval-pair expr)
                     (cons (cons 'test-name tname) line))))
      (((_ etype expr) line)
       (syntax (%test-error etype (%eval-pair expr) line)))
      (((_ expr) line)
       (syntax (%test-error #t (%eval-pair expr) line))))))

Re: SRFI-64 implementation for Guile 2.0

[Per Bothner]

This is nice.  It would be great if the Guile port would be merged
into the reference implementation, presumably using cond-expand.
That way bug-fixes or changes in one could be more easily be
merged into the other.

The use of #:KEYWORD syntax might cause reader problems on some
Scheme implementations, even when using cond-expand, though not on Kawa.
One option is for the Guile port to contain the define-module in a
separate file, which does an include on (a suitably enhanced)
version of the portable implementation.  (I assume Guild has
include or something similar.)
-- 
	--Per Bothner
per@bothner.com   http://per.bothner.com/

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 974 bytes --]

I rewrote srfi/srfi-64.scm file using cond-expand but don't know it works.
On Guile 2.0, it works;
  $ guile -L `pwd` --use-srfi=64 srfi-64-test.scm
  %%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI
64 - Meta-Test Suite.log")
  # of expected passes      51
  # of expected failures    2

2012/4/14 Per Bothner <per@bothner.com>

> This is nice.  It would be great if the Guile port would be merged
> into the reference implementation, presumably using cond-expand.
> That way bug-fixes or changes in one could be more easily be
> merged into the other.
>

I have no idea how to use your testing.scm file on Kawa or Chicken.
Without testing.scm file, srfi-64-test.scm can be checked on Kawa;
  $ kawa srfi-64-test.scm
  %%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI
64 - Meta-Test Suite.log")
  # of expected passes      51
  # of expected failures    2
I don't know how to use testing.scm and my srfi/srfi-64.scm on Kawa.

[-- Attachment #1.2: Type: text/html, Size: 1441 bytes --]

[-- Attachment #2: srfi-64.scm.gz --]
[-- Type: application/x-gzip, Size: 7606 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 1381 bytes --]

Now, srfi-64.scm works on Guile 1.8 and 2.0.

There are two different thins;
  1) Guile 1.8 does not support nested block comments.
     So, it does not pass srfi-64-test.scm test suite.
     But, comments are comments - not problem.
  2) srfi-64.scm on Guile 2.0 can catch and report the source form
     like this;
       source-file: "srfi-64-test.scm"
       source-line: 129
       source-form: (test-equal "1.1.1. Very simple" (quote (("a") ("b") ()
() () (1 1 0 0 0))) (t))
     srfi-64.scm on Guile 1.8 does not support it yet
     because I'm a newbie of scheme and don't understand Guile yet.
     I hope someone fix these problems;
       a) On Guile 2.0, I used (datum->syntax form (syntax->datum form))
       b) On Guile 2.0, I used (assq-ref (syntax-source form) 'filename)

2012/4/14 Sunjoong Lee <sunjoong@gmail.com>
>
> 2012/4/14 Per Bothner <per@bothner.com>
>
>> This is nice.  It would be great if the Guile port would be merged
>> into the reference implementation, presumably using cond-expand.
>> That way bug-fixes or changes in one could be more easily be
>> merged into the other.
>
>
Now, srfi-64.scm works on Chicken 4.7.

Per Bothner adviced me it's better to merge it into the reference
implementation.
I was not convinced to check right merge.
So, I ported it for Chicken 4.7 and Guile 1.8 - it works now.
Right merge? I'm not sure yet but hope so.

[-- Attachment #1.2: Type: text/html, Size: 2248 bytes --]

[-- Attachment #2: srfi-64.scm.gz --]
[-- Type: application/x-gzip, Size: 8101 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Noah Lavine]

Hello!

I'm a bit confused by this conversation. Do you want to merge this
code into Guile, or into the reference implementation of SRFI 64?

If it's into Guile, I can't speak for the maintainers, but I think we
would love to have it. We do like supporting SRFIs.

Thanks,
Noah

On Sun, Apr 15, 2012 at 4:35 PM, Sunjoong Lee <sunjoong@gmail.com> wrote:
> Now, srfi-64.scm works on Guile 1.8 and 2.0.
>
> There are two different thins;
>   1) Guile 1.8 does not support nested block comments.
>      So, it does not pass srfi-64-test.scm test suite.
>      But, comments are comments - not problem.
>   2) srfi-64.scm on Guile 2.0 can catch and report the source form
>      like this;
>        source-file: "srfi-64-test.scm"
>        source-line: 129
>        source-form: (test-equal "1.1.1. Very simple" (quote (("a") ("b") ()
> () () (1 1 0 0 0))) (t))
>      srfi-64.scm on Guile 1.8 does not support it yet
>      because I'm a newbie of scheme and don't understand Guile yet.
>      I hope someone fix these problems;
>        a) On Guile 2.0, I used (datum->syntax form (syntax->datum form))
>        b) On Guile 2.0, I used (assq-ref (syntax-source form) 'filename)
>
> 2012/4/14 Sunjoong Lee <sunjoong@gmail.com>
>>
>> 2012/4/14 Per Bothner <per@bothner.com>
>>>
>>> This is nice.  It would be great if the Guile port would be merged
>>> into the reference implementation, presumably using cond-expand.
>>> That way bug-fixes or changes in one could be more easily be
>>> merged into the other.
>
>
> Now, srfi-64.scm works on Chicken 4.7.
>
> Per Bothner adviced me it's better to merge it into the reference
> implementation.
> I was not convinced to check right merge.
> So, I ported it for Chicken 4.7 and Guile 1.8 - it works now.
> Right merge? I'm not sure yet but hope so.
>

Re: SRFI-64 implementation for Guile 2.0

[Per Bothner]

On 04/19/2012 07:50 PM, Noah Lavine wrote:
> Hello!
>
> I'm a bit confused by this conversation. Do you want to merge this
> code into Guile, or into the reference implementation of SRFI 64?
>
> If it's into Guile, I can't speak for the maintainers, but I think we
> would love to have it. We do like supporting SRFIs.

I think it would be great to get SRFI-64 into Guile.

My suggestion was that it would be nice (but not essential)
if the Guile implementation could be based on and merged back into
the reference implementation, perhaps using cond-expand to
encapsulate the Guile-specific changes.

Unfortunately, this Guile port seems like a complete rewrite:
The diff (relative to the reference implementation) is over twice as big
as than the original reference implementation!  This makes it difficult
to evaluate the changes, which makes it difficult to accept it as an
update to the reference implementation.  I was hoping the Guile port would
be a modest set of changes to the reference implementation; this is not.

I tried loading the reference implementation into Guile, and it
seems to work, albeit only with the basic (portable) functionality:;
see the end of this message.

Better support includes source-line-numbers, and exception trapping,
which are of course implementation-specific.  But my goal was
that support could be added by modest changes.  For example
line numbers are handled by the %test-source-line2 macro,
which is defined inside a cond-expand.  Could support be added
for Guile inside the cond-expand?

Now it is possible there may be more structural problems with the
reference implementation, and I'm certainly willing to consider those.
But I'm unclear if that is the case.

Sample run of the reference implementation:

$ guile -l ~/Kawa/work1/gnu/kawa/slib/testing.scm --
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling /home/bothner/Kawa/work1/gnu/kawa/slib/testing.scm
;;; /home/bothner/Kawa/work1/gnu/kawa/slib/testing.scm:978:8: warning: 
possibly wrong number of arguments to `eval'
;;; compiled 
/home/bothner/.cache/guile/ccache/2.0-LE-8-2.0/home/bothner/Kawa/work1/gnu/kawa/slib/testing.scm.go
GNU Guile 2.0.5-deb+1-1
Copyright (C) 1995-2012 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
scheme@(guile-user)> (test-begin "vec-test")
%%%% Starting test vec-test  (Writing full log to "vec-test.log")
$1 = ("vec-test")
scheme@(guile-user)> (define v (make-vector 5 99))
scheme@(guile-user)> (test-assert (vector? v))
scheme@(guile-user)> (test-eqv 99 (vector-ref v 2))
scheme@(guile-user)> (vector-set! v 2 7)
scheme@(guile-user)> (test-eqv 7 (vector-ref v 2))
scheme@(guile-user)> (test-eqv 8 (vector-ref v 2))
FAIL
scheme@(guile-user)> (test-end "vec-test")
# of expected passes      3
# of unexpected failures  1
scheme@(guile-user)>

Some deprecated features have been used.  Set the environment
variable GUILE_WARN_DEPRECATED to "detailed" and rerun the
program to get more information.  Set it to "no" to suppress
this message.
$ cat vec-test.log
%%%% Starting test vec-test
Group begin: vec-test
Test begin:
Test end:
   result-kind: pass
   actual-value: #t
Test begin:
Test end:
   result-kind: pass
   actual-value: 99
   expected-value: 99
Test begin:
Test end:
   result-kind: pass
   actual-value: 7
   expected-value: 7
Test begin:
Test end:
   result-kind: fail
   actual-value: 7
   expected-value: 8
Group end: vec-test
# of expected passes      3
# of unexpected failures  1
$

Adding line-number importation woudl of course make this much nicer.
Running the same on Kawa yields:
%%%% Starting test vec-test
Group begin: vec-test
Test begin:
   source-file: "/dev/stdin"
   source-line: 3
   source-form: (test-assert (vector? v))
Test end:
   result-kind: pass
   actual-value: #t
Test begin:
   source-file: "/dev/stdin"
   source-line: 4
   source-form: (test-eqv 99 (vector-ref v 2))
Test end:
   result-kind: pass
   actual-value: 99
   expected-value: 99
Test begin:
   source-file: "/dev/stdin"
   source-line: 6
   source-form: (test-eqv 7 (vector-ref v 2))
Test end:
   result-kind: pass
   actual-value: 7
   expected-value: 7
Test begin:
   source-file: "/dev/stdin"
   source-line: 7
   source-form: (test-eqv 8 (vector-ref v 2))
Test end:
   result-kind: fail
   actual-value: 7
   expected-value: 8
Group end: vec-test
# of expected passes      3
# of unexpected failures  1

Also the FAIL printed to stderr lists the file and line number:

|kawa:7|# (test-eqv 8 (vector-ref v 2))
/dev/stdin:7: FAIL
-- 
	--Per Bothner
per@bothner.com   http://per.bothner.com/

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 1430 bytes --]

Thanks Noah and Per;

English language is more difficult than scheme language for me. :(
I want to share my code or modification to others and learn somethings
during that.

Few days ago, I found testing.scm, the reference implementation of SRFI 64,
does not pass srfi-64-test.scm, a test suite for the SRFI 64, on Guile 2.0.
The cause is defining test-apply before defining test-with-runner in
testing.scm.
I did not realize it then and try to understand how testing.scm work.

I'll attatch two files on this mail; srfi-64.scm.gz and testing.patch.gz.
The srfi-64.scm.gz file is for Guile, Chicken and Gambit users.
The testing.patch.gz file is for Per.

2012/4/20 Per Bothner <per@bothner.com>

> On 04/19/2012 07:50 PM, Noah Lavine wrote:
>>
>> I'm a bit confused by this conversation. Do you want to merge this
>> code into Guile, or into the reference implementation of SRFI 64?
>>
>
If it's into Guile, I'll feel happy.
If it's of helpful to Per, I'll feel happy too.

Unfortunately, this Guile port seems like a complete rewrite:
> The diff (relative to the reference implementation) is over twice as big
> as than the original reference implementation!
>

Humm....
Even after applying patch, testing.scm is not same to srfi-64.scm because
of the order and style of definitions.
The order of definitions, I fixed testing.scm for on Guile but not
on Chicken.
The srfi-64.scm can be compiled and loaded by module on Chicken.

[-- Attachment #1.2: Type: text/html, Size: 2194 bytes --]

[-- Attachment #2: srfi-64.scm.gz --]
[-- Type: application/x-gzip, Size: 8383 bytes --]

[-- Attachment #3: testing.patch.gz --]
[-- Type: application/x-gzip, Size: 3523 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Per Bothner]

[-- Attachment #1: Type: text/plain, Size: 1135 bytes --]

On 04/20/2012 03:19 AM, Sunjoong Lee wrote:
> I'll attatch two files on this mail; srfi-64.scm.gz and testing.patch.gz.
> The srfi-64.scm.gz file is for Guile, Chicken and Gambit users.
> The testing.patch.gz file is for Per.

Much better.  I applied your patch to the reference implementation,
and that seems to work.  I source file name and line numbers, which
makes things much more pleasant.

I'm going to look at the patch in detail, but before I do, a question:
Why is your srfi-64.scm.gz "for Guile, Chicken and Gambit" so very
different from the reference implementation with your patch applied?
You mention "the order and style of definitions".  Could you be more
specific?  I can certainly re-order definitions if that will help,
but I'd like to understand why.  And I'd prefer to re-order them myself.
For example: "macro x needs to be moved before function y because of z".
And what is the problem with the "style"?  A module issue?

I made a few snall fixes in 2007 to testing.scm which I guess I
forgot to get uploaded to srfi,schemers,org.  I've attached it.
-- 
	--Per Bothner
per@bothner.com   http://per.bothner.com/

[-- Attachment #2: testing.scm --]
[-- Type: text/plain, Size: 33697 bytes --]

;; Copyright (c) 2005, 2006, 2007 Per Bothner
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(cond-expand
 (chicken
  (require-extension syntax-case))
 (guile
  (use-modules (ice-9 syncase) (srfi srfi-9)
	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
	       (srfi srfi-39)))
 (sisc
  (require-extension (srfi 9 34 35 39)))
 (kawa
  (module-compile-options warn-undefined-variable: #t
			  warn-invoke-unknown-method: #t)
  (provide 'srfi-64)
  (provide 'testing)
  (require 'srfi-34)
  (require 'srfi-35))
 (else ()
  ))

(cond-expand
 (kawa
  (define-syntax %test-export
    (syntax-rules ()
      ((%test-export test-begin . other-names)
       (module-export %test-begin . other-names)))))
 (else
  (define-syntax %test-export
    (syntax-rules ()
      ((%test-export . names) (if #f #f))))))

;; List of exported names
(%test-export
 test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
 test-end test-assert test-eqv test-eq test-equal
 test-approximate test-assert test-error test-apply test-with-runner
 test-match-nth test-match-all test-match-any test-match-name
 test-skip test-expect-fail test-read-eval-string
 test-runner-group-path test-group-with-cleanup
 test-result-ref test-result-set! test-result-clear test-result-remove
 test-result-kind test-passed?
 test-log-to-file
 ; Misc test-runner functions
 test-runner? test-runner-reset test-runner-null
 test-runner-simple test-runner-current test-runner-factory test-runner-get
 test-runner-create test-runner-test-name
 ;; test-runner field setter and getter functions - see %test-record-define:
 test-runner-pass-count test-runner-pass-count!
 test-runner-fail-count test-runner-fail-count!
 test-runner-xpass-count test-runner-xpass-count!
 test-runner-xfail-count test-runner-xfail-count!
 test-runner-skip-count test-runner-skip-count!
 test-runner-group-stack test-runner-group-stack!
 test-runner-on-test-begin test-runner-on-test-begin!
 test-runner-on-test-end test-runner-on-test-end!
 test-runner-on-group-begin test-runner-on-group-begin!
 test-runner-on-group-end test-runner-on-group-end!
 test-runner-on-final test-runner-on-final!
 test-runner-on-bad-count test-runner-on-bad-count!
 test-runner-on-bad-end-name test-runner-on-bad-end-name!
 test-result-alist test-result-alist!
 test-runner-aux-value test-runner-aux-value!
 ;; default/simple call-back functions, used in default test-runner,
 ;; but can be called to construct more complex ones.
 test-on-group-begin-simple test-on-group-end-simple
 test-on-bad-count-simple test-on-bad-end-name-simple
 test-on-final-simple test-on-test-end-simple
 test-on-final-simple)

(cond-expand
 (srfi-9
  (define-syntax %test-record-define
    (syntax-rules ()
      ((%test-record-define alloc runner? (name index setter getter) ...)
       (define-record-type test-runner
	 (alloc)
	 runner?
	 (name setter getter) ...)))))
 (else
  (define %test-runner-cookie (list "test-runner"))
  (define-syntax %test-record-define
    (syntax-rules ()
      ((%test-record-define alloc runner? (name index getter setter) ...)
       (begin
	 (define (runner? obj)
	   (and (vector? obj)
		(> (vector-length obj) 1)
		(eq (vector-ref obj 0) %test-runner-cookie)))
	 (define (alloc)
	   (let ((runner (make-vector 23)))
	     (vector-set! runner 0 %test-runner-cookie)
	     runner))
	 (begin
	   (define (getter runner)
	     (vector-ref runner index)) ...)
	 (begin
	   (define (setter runner value)
	     (vector-set! runner index value)) ...)))))))

(%test-record-define
 %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!)
 (fail-count 2 test-runner-fail-count test-runner-fail-count!)
 (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
 (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
 (skip-count 5 test-runner-skip-count test-runner-skip-count!)
 (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
 (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
 ;; Normally #t, except when in a test-apply.
 (run-list 8 %test-runner-run-list %test-runner-run-list!)
 (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
 (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
 (group-stack 11 test-runner-group-stack test-runner-group-stack!)
 (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
 (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
 ;; Call-back when entering a group. Takes (runner suite-name count).
 (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
 ;; Call-back when leaving a group.
 (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
 ;; Call-back when leaving the outermost group.
 (on-final 16 test-runner-on-final test-runner-on-final!)
 ;; Call-back when expected number of tests was wrong.
 (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
 ;; Call-back when name in test=end doesn't match test-begin.
 (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
 ;; Cumulate count of all tests that have been done.
 (total-count 19 %test-runner-total-count %test-runner-total-count!)
 ;; Stack (list) of (count-at-start . expected-count):
 (count-list 20 %test-runner-count-list %test-runner-count-list!)
 (result-alist 21 test-result-alist test-result-alist!)
 ;; Field can be used by test-runner for any purpose.
 ;; test-runner-simple uses it for a log file.
 (aux-value 22 test-runner-aux-value test-runner-aux-value!)
)

(define (test-runner-reset runner)
    (test-result-alist! runner '())
    (test-runner-pass-count! runner 0)
    (test-runner-fail-count! runner 0)
    (test-runner-xpass-count! runner 0)
    (test-runner-xfail-count! runner 0)
    (test-runner-skip-count! runner 0)
    (%test-runner-total-count! runner 0)
    (%test-runner-count-list! runner '())
    (%test-runner-run-list! runner #t)
    (%test-runner-skip-list! runner '())
    (%test-runner-fail-list! runner '())
    (%test-runner-skip-save! runner '())
    (%test-runner-fail-save! runner '())
    (test-runner-group-stack! runner '()))

(define (test-runner-group-path runner)
  (reverse (test-runner-group-stack runner)))

(define (%test-null-callback runner) #f)

(define (test-runner-null)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
    (test-runner-on-group-end! runner %test-null-callback)
    (test-runner-on-final! runner %test-null-callback)
    (test-runner-on-test-begin! runner %test-null-callback)
    (test-runner-on-test-end! runner %test-null-callback)
    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
    runner))

;; Not part of the specification.  FIXME
;; Controls whether a log file is generated.
(define test-log-to-file #t)

(define (test-runner-simple)
  (let ((runner (%test-runner-alloc)))
    (test-runner-reset runner)
    (test-runner-on-group-begin! runner test-on-group-begin-simple)
    (test-runner-on-group-end! runner test-on-group-end-simple)
    (test-runner-on-final! runner test-on-final-simple)
    (test-runner-on-test-begin! runner test-on-test-begin-simple)
    (test-runner-on-test-end! runner test-on-test-end-simple)
    (test-runner-on-bad-count! runner test-on-bad-count-simple)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))

(cond-expand
 (srfi-39
  (define test-runner-current (make-parameter #f))
  (define test-runner-factory (make-parameter test-runner-simple)))
 (else
  (define %test-runner-current #f)
  (define-syntax test-runner-current
    (syntax-rules ()
      ((test-runner-current)
       %test-runner-current)
      ((test-runner-current runner)
       (set! %test-runner-current runner))))
  (define %test-runner-factory test-runner-simple)
  (define-syntax test-runner-factory
    (syntax-rules ()
      ((test-runner-factory)
       %test-runner-factory)
      ((test-runner-factory runner)
       (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))

(define (%test-specificier-matches spec runner)
  (spec runner))

(define (test-runner-create)
  ((test-runner-factory)))

(define (%test-any-specifier-matches list runner)
  (let ((result #f))
    (let loop ((l list))
      (cond ((null? l) result)
	    (else
	     (if (%test-specificier-matches (car l) runner)
		 (set! result #t))
	     (loop (cdr l)))))))

;; Returns #f, #t, or 'xfail.
(define (%test-should-execute runner)
  (let ((run (%test-runner-run-list runner)))
    (cond ((or
	    (not (or (eqv? run #t)
		     (%test-any-specifier-matches run runner)))
	    (%test-any-specifier-matches
	     (%test-runner-skip-list runner)
	     runner))
	    (test-result-set! runner 'result-kind 'skip)
	    #f)
	  ((%test-any-specifier-matches
	    (%test-runner-fail-list runner)
	    runner)
	   (test-result-set! runner 'result-kind 'xfail)
	   'xfail)
	  (else #t))))

(define (%test-begin suite-name count)
  (if (not (test-runner-current))
      (test-runner-current (test-runner-create)))
  (let ((runner (test-runner-current)))
    ((test-runner-on-group-begin runner) runner suite-name count)
    (%test-runner-skip-save! runner
			       (cons (%test-runner-skip-list runner)
				     (%test-runner-skip-save runner)))
    (%test-runner-fail-save! runner
			       (cons (%test-runner-fail-list runner)
				     (%test-runner-fail-save runner)))
    (%test-runner-count-list! runner
			     (cons (cons (%test-runner-total-count runner)
					 count)
				   (%test-runner-count-list runner)))
    (test-runner-group-stack! runner (cons suite-name
					(test-runner-group-stack runner)))))
(cond-expand
 (kawa
  ;; Kawa has test-begin built in, implemented as:
  ;; (begin
  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
  ;;   (%test-begin suite-name [count]))
  ;; This puts test-begin but only test-begin in the default environment.,
  ;; which makes normal test suites loadable without non-portable commands.
  )
 (else
  (define-syntax test-begin
    (syntax-rules ()
      ((test-begin suite-name)
       (%test-begin suite-name #f))
      ((test-begin suite-name count)
       (%test-begin suite-name count))))))

(define (test-on-group-begin-simple runner suite-name count)
  (if (null? (test-runner-group-stack runner))
      (begin
	(display "%%%% Starting test ")
	(display suite-name)
	(if test-log-to-file
	    (let* ((log-file-name
		    (if (string? test-log-to-file) test-log-to-file
			(string-append suite-name ".log")))
		   (log-file
		    (cond-expand (mzscheme
				  (open-output-file log-file-name 'truncate/replace))
				 (else (open-output-file log-file-name)))))
	      (display "%%%% Starting test " log-file)
	      (display suite-name log-file)
	      (newline log-file)
	      (test-runner-aux-value! runner log-file)
	      (display "  (Writing full log to \"")
	      (display log-file-name)
	      (display "\")")))
	(newline)))
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
	(begin
	  (display "Group begin: " log)
	  (display suite-name log)
	  (newline log))))
  #f)

(define (test-on-group-end-simple runner)
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
	(begin
	  (display "Group end: " log)
	  (display (car (test-runner-group-stack runner)) log)
	  (newline log))))
  #f)

(define (%test-on-bad-count-write runner count expected-count port)
  (display "*** Total number of tests was " port)
  (display count port)
  (display " but should be " port)
  (display expected-count port)
  (display ". ***" port)
  (newline port)
  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
  (newline port))

(define (test-on-bad-count-simple runner count expected-count)
  (%test-on-bad-count-write runner count expected-count (current-output-port))
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
	(%test-on-bad-count-write runner count expected-count log))))

(define (test-on-bad-end-name-simple runner begin-name end-name)
  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
			    " does not match test-begin " end-name)))
    (cond-expand
     (srfi-23 (error msg))
     (else (display msg) (newline)))))
  

(define (%test-final-report1 value label port)
  (if (> value 0)
      (begin
	(display label port)
	(display value port)
	(newline port))))

(define (%test-final-report-simple runner port)
  (%test-final-report1 (test-runner-pass-count runner)
		      "# of expected passes      " port)
  (%test-final-report1 (test-runner-xfail-count runner)
		      "# of expected failures    " port)
  (%test-final-report1 (test-runner-xpass-count runner)
		      "# of unexpected successes " port)
  (%test-final-report1 (test-runner-fail-count runner)
		      "# of unexpected failures  " port)
  (%test-final-report1 (test-runner-skip-count runner)
		      "# of skipped tests        " port))

(define (test-on-final-simple runner)
  (%test-final-report-simple runner (current-output-port))
  (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
	(%test-final-report-simple runner log))))

(define (%test-format-line runner)
   (let* ((line-info (test-result-alist runner))
	  (source-file (assq 'source-file line-info))
	  (source-line (assq 'source-line line-info))
	  (file (if source-file (cdr source-file) "")))
     (if source-line
	 (string-append file ":"
			(number->string (cdr source-line)) ": ")
	 "")))

(define (%test-end suite-name line-info)
  (let* ((r (test-runner-get))
	 (groups (test-runner-group-stack r))
	 (line (%test-format-line r)))
    (test-result-alist! r line-info)
    (if (null? groups)
	(let ((msg (string-append line "test-end not in a group")))
	  (cond-expand
	   (srfi-23 (error msg))
	   (else (display msg) (newline)))))
    (if (and suite-name (not (equal? suite-name (car groups))))
	((test-runner-on-bad-end-name r) r suite-name (car groups)))
    (let* ((count-list (%test-runner-count-list r))
	   (expected-count (cdar count-list))
	   (saved-count (caar count-list))
	   (group-count (- (%test-runner-total-count r) saved-count)))
      (if (and expected-count
	       (not (= expected-count group-count)))
	  ((test-runner-on-bad-count r) r group-count expected-count))
      ((test-runner-on-group-end r) r)
      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
      (%test-runner-count-list! r (cdr count-list))
      (if (null? (test-runner-group-stack r))
	  ((test-runner-on-final r) r)))))

(define-syntax test-group
  (syntax-rules ()
    ((test-group suite-name . body)
     (let ((r (test-runner-current)))
       ;; Ideally should also set line-number, if available.
       (test-result-alist! r (list (cons 'test-name suite-name)))
       (if (%test-should-execute r)
	   (dynamic-wind
	       (lambda () (test-begin suite-name))
	       (lambda () . body)
	       (lambda () (test-end  suite-name))))))))

(define-syntax test-group-with-cleanup
  (syntax-rules ()
    ((test-group-with-cleanup suite-name form cleanup-form)
     (test-group suite-name
		    (dynamic-wind
			(lambda () #f)
			(lambda () form)
			(lambda () cleanup-form))))
    ((test-group-with-cleanup suite-name cleanup-form)
     (test-group-with-cleanup suite-name #f cleanup-form))
    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))

(define (test-on-test-begin-simple runner)
 (let ((log (test-runner-aux-value runner)))
    (if (output-port? log)
	(let* ((results (test-result-alist runner))
	       (source-file (assq 'source-file results))
	       (source-line (assq 'source-line results))
	       (source-form (assq 'source-form results))
	       (test-name (assq 'test-name results)))
	  (display "Test begin:" log)
	  (newline log)
	  (if test-name (%test-write-result1 test-name log))
	  (if source-file (%test-write-result1 source-file log))
	  (if source-line (%test-write-result1 source-line log))
	  (if source-file (%test-write-result1 source-form log))))))

(define-syntax test-result-ref
  (syntax-rules ()
    ((test-result-ref runner pname)
     (test-result-ref runner pname #f))
    ((test-result-ref runner pname default)
     (let ((p (assq pname (test-result-alist runner))))
       (if p (cdr p) default)))))

(define (test-on-test-end-simple runner)
  (let ((log (test-runner-aux-value runner))
	(kind (test-result-ref runner 'result-kind)))
    (if (memq kind '(fail xpass))
	(let* ((results (test-result-alist runner))
	       (source-file (assq 'source-file results))
	       (source-line (assq 'source-line results))
	       (test-name (assq 'test-name results)))
	  (if (or source-file source-line)
	      (begin
		(if source-file (display (cdr source-file)))
		(display ":")
		(if source-line (display (cdr source-line)))
		(display ": ")))
	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
	  (if test-name
	      (begin
		(display " ")
		(display (cdr test-name))))
	  (newline)))
    (if (output-port? log)
	(begin
	  (display "Test end:" log)
	  (newline log)
	  (let loop ((list (test-result-alist runner)))
	    (if (pair? list)
		(let ((pair (car list)))
		  ;; Write out properties not written out by on-test-begin.
		  (if (not (memq (car pair)
				 '(test-name source-file source-line source-form)))
		      (%test-write-result1 pair log))
		  (loop (cdr list)))))))))

(define (%test-write-result1 pair port)
  (display "  " port)
  (display (car pair) port)
  (display ": " port)
  (write (cdr pair) port)
  (newline port))

(define (test-result-set! runner pname value)
  (let* ((alist (test-result-alist runner))
	 (p (assq pname alist)))
    (if p
	(set-cdr! p value)
	(test-result-alist! runner (cons (cons pname value) alist)))))

(define (test-result-clear runner)
  (test-result-alist! runner '()))

(define (test-result-remove runner pname)
  (let* ((alist (test-result-alist runner))
	 (p (assq pname alist)))
    (if p
	(test-result-alist! runner
				   (let loop ((r alist))
				     (if (eq? r p) (cdr r)
					 (cons (car r) (loop (cdr r)))))))))

(define (test-result-kind . rest)
  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
    (test-result-ref runner 'result-kind)))

(define (test-passed? . rest)
  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
    (memq (test-result-ref runner 'result-kind) '(pass xpass))))

(define (%test-report-result)
  (let* ((r (test-runner-get))
	 (result-kind (test-result-kind r)))
    (case result-kind
      ((pass)
       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
      ((fail)
       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
      ((xpass)
       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
      ((xfail)
       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
      (else
       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
    ((test-runner-on-test-end r) r)))

(cond-expand
 (guile
  (define-syntax %test-evaluate-with-catch
    (syntax-rules ()
      ((%test-evaluate-with-catch test-expression)
       (catch #t (lambda () test-expression) (lambda (key . args) #f))))))
 (kawa
  (define-syntax %test-evaluate-with-catch
    (syntax-rules ()
      ((%test-evaluate-with-catch test-expression)
       (try-catch test-expression
		  (ex <java.lang.Throwable>
		      (test-result-set! (test-runner-current) 'actual-error ex)
		      #f))))))
 (srfi-34
  (define-syntax %test-evaluate-with-catch
    (syntax-rules ()
      ((%test-evaluate-with-catch test-expression)
       (guard (err (else #f)) test-expression)))))
 (chicken
  (define-syntax %test-evaluate-with-catch
    (syntax-rules ()
      ((%test-evaluate-with-catch test-expression)
       (condition-case test-expression (ex () #f))))))
 (else
  (define-syntax %test-evaluate-with-catch
    (syntax-rules ()
      ((%test-evaluate-with-catch test-expression)
       test-expression)))))
	    
(cond-expand
 ((or kawa mzscheme)
  (cond-expand
   (mzscheme
    (define-for-syntax (%test-syntax-file form)
      (let ((source (syntax-source form)))
	(cond ((string? source) file)
				((path? source) (path->string source))
				(else #f)))))
   (kawa
    (define (%test-syntax-file form)
      (syntax-source form))))
  (define (%test-source-line2 form)
    (let* ((line (syntax-line form))
	   (file (%test-syntax-file form))
	   (line-pair (if line (list (cons 'source-line line)) '())))
      (cons (cons 'source-form (syntax-object->datum form))
	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
 (else
  (define (%test-source-line2 form)
    '())))

(define (%test-on-test-begin r)
  (%test-should-execute r)
  ((test-runner-on-test-begin r) r)
  (not (eq? 'skip (test-result-ref r 'result-kind))))

(define (%test-on-test-end r result)
    (test-result-set! r 'result-kind
		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
			  (if result 'xpass 'xfail)
			  (if result 'pass 'fail))))

(define (test-runner-test-name runner)
  (test-result-ref runner 'test-name ""))

(define-syntax %test-comp2body
  (syntax-rules ()
		((%test-comp2body r comp expected expr)
		 (let ()
		   (if (%test-on-test-begin r)
		       (let ((exp expected))
			 (test-result-set! r 'expected-value exp)
			 (let ((res (%test-evaluate-with-catch expr)))
			   (test-result-set! r 'actual-value res)
			   (%test-on-test-end r (comp exp res)))))
		   (%test-report-result)))))

(define (%test-approximimate= error)
  (lambda (value expected)
    (and (>= value (- expected error))
         (<= value (+ expected error)))))

(define-syntax %test-comp1body
  (syntax-rules ()
    ((%test-comp1body r expr)
     (let ()
       (if (%test-on-test-begin r)
	   (let ()
	     (let ((res (%test-evaluate-with-catch expr)))
	       (test-result-set! r 'actual-value res)
	       (%test-on-test-end r res))))
       (%test-report-result)))))

(cond-expand
 ((or kawa mzscheme)
  ;; Should be made to work for any Scheme with syntax-case
  ;; However, I haven't gotten the quoting working.  FIXME.
  (define-syntax test-end
    (lambda (x)
      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
	(((mac suite-name) line)
	 (syntax
	  (%test-end suite-name line)))
	(((mac) line)
	 (syntax
	  (%test-end #f line))))))
  (define-syntax test-assert
    (lambda (x)
      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
	(((mac tname expr) line)
	 (syntax
	  (let* ((r (test-runner-get))
		 (name tname))
	    (test-result-alist! r (cons (cons 'test-name tname) line))
	    (%test-comp1body r expr))))
	(((mac expr) line)
	 (syntax
	  (let* ((r (test-runner-get)))
	    (test-result-alist! r line)
	    (%test-comp1body r expr)))))))
  (define (%test-comp2 comp x)
    (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) ()
      (((mac tname expected expr) line comp)
       (syntax
	(let* ((r (test-runner-get))
	       (name tname))
	  (test-result-alist! r (cons (cons 'test-name tname) line))
	  (%test-comp2body r comp expected expr))))
      (((mac expected expr) line comp)
       (syntax
	(let* ((r (test-runner-get)))
	  (test-result-alist! r line)
	  (%test-comp2body r comp expected expr))))))
  (define-syntax test-eqv
    (lambda (x) (%test-comp2 (syntax eqv?) x)))
  (define-syntax test-eq
    (lambda (x) (%test-comp2 (syntax eq?) x)))
  (define-syntax test-equal
    (lambda (x) (%test-comp2 (syntax equal?) x)))
  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
    (lambda (x)
      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
      (((mac tname expected expr error) line)
       (syntax
	(let* ((r (test-runner-get))
	       (name tname))
	  (test-result-alist! r (cons (cons 'test-name tname) line))
	  (%test-comp2body r (%test-approximimate= error) expected expr))))
      (((mac expected expr error) line)
       (syntax
	(let* ((r (test-runner-get)))
	  (test-result-alist! r line)
	  (%test-comp2body r (%test-approximimate= error) expected expr))))))))
 (else
  (define-syntax test-end
    (syntax-rules ()
      ((test-end)
       (%test-end #f '()))
      ((test-end suite-name)
       (%test-end suite-name '()))))
  (define-syntax test-assert
    (syntax-rules ()
      ((test-assert tname test-expression)
       (let* ((r (test-runner-get))
	      (name tname))
	 (test-result-alist! r '((test-name . tname)))
	 (%test-comp1body r test-expression)))
      ((test-assert test-expression)
       (let* ((r (test-runner-get)))
	 (test-result-alist! r '())
	 (%test-comp1body r test-expression)))))
  (define-syntax %test-comp2
    (syntax-rules ()
      ((%test-comp2 comp tname expected expr)
       (let* ((r (test-runner-get))
	      (name tname))
	 (test-result-alist! r (list (cons 'test-name tname)))
	 (%test-comp2body r comp expected expr)))
      ((%test-comp2 comp expected expr)
       (let* ((r (test-runner-get)))
	 (test-result-alist! r '())
	 (%test-comp2body r comp expected expr)))))
  (define-syntax test-equal
    (syntax-rules ()
      ((test-equal . rest)
       (%test-comp2 equal? . rest))))
  (define-syntax test-eqv
    (syntax-rules ()
      ((test-eqv . rest)
       (%test-comp2 eqv? . rest))))
  (define-syntax test-eq
    (syntax-rules ()
      ((test-eq . rest)
       (%test-comp2 eq? . rest))))
  (define-syntax test-approximate
    (syntax-rules ()
      ((test-approximate tname expected expr error)
       (%test-comp2 (%test-approximimate= error) tname expected expr))
      ((test-approximate expected expr error)
       (%test-comp2 (%test-approximimate= error) expected expr))))))

(cond-expand
 (guile
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
       (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t)))))))
 (mzscheme
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
					 (let ()
					   (test-result-set! r 'actual-value expr)
					   #f)))))))
 (chicken
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
        (%test-comp1body r (condition-case expr (ex () #t)))))))
 (kawa
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r #t expr)
       (cond ((%test-on-test-begin r)
	      (test-result-set! r 'expected-error #t)
	      (%test-on-test-end r
				 (try-catch
				  (let ()
				    (test-result-set! r 'actual-value expr)
				    #f)
				  (ex <java.lang.Throwable>
				      (test-result-set! r 'actual-error ex)
				      #t)))
	      (%test-report-result))))
      ((%test-error r etype expr)
       (if (%test-on-test-begin r)
	   (let ((et etype))
	     (test-result-set! r 'expected-error et)
	     (%test-on-test-end r
				(try-catch
				 (let ()
				   (test-result-set! r 'actual-value expr)
				   #f)
				 (ex <java.lang.Throwable>
				     (test-result-set! r 'actual-error ex)
				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
					    (instance? ex et))
					   (else #t)))))
	     (%test-report-result)))))))
 ((and srfi-34 srfi-35)
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
       (%test-comp1body r (guard (ex ((condition-type? etype)
		   (and (condition? ex) (condition-has-type? ex etype)))
		  ((procedure? etype)
		   (etype ex))
		  ((equal? type #t)
		   #t)
		  (else #t))
	      expr))))))
 (srfi-34
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
       (%test-comp1body r (guard (ex (else #t)) expr))))))
 (else
  (define-syntax %test-error
    (syntax-rules ()
      ((%test-error r etype expr)
       (begin
	 ((test-runner-on-test-begin r) r)
	 (test-result-set! r 'result-kind 'skip)
	 (%test-report-result)))))))

(cond-expand
 ((or kawa mzscheme)

  (define-syntax test-error
    (lambda (x)
      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
	(((mac tname etype expr) line)
	 (syntax
	  (let* ((r (test-runner-get))
		 (name tname))
	    (test-result-alist! r (cons (cons 'test-name tname) line))
	    (%test-error r etype expr))))
	(((mac etype expr) line)
	 (syntax
	  (let* ((r (test-runner-get)))
	    (test-result-alist! r line)
	    (%test-error r etype expr))))
	(((mac expr) line)
	 (syntax
	  (let* ((r (test-runner-get)))
	    (test-result-alist! r line)
	    (%test-error r #t expr))))))))
 (else
  (define-syntax test-error
    (syntax-rules ()
      ((test-error name etype expr)
       (test-assert name (%test-error etype expr)))
      ((test-error etype expr)
       (test-assert (%test-error etype expr)))
      ((test-error expr)
       (test-assert (%test-error #t expr)))))))

(define (test-apply first . rest)
  (if (test-runner? first)
      (test-with-runner first (apply test-apply rest))
      (let ((r (test-runner-current)))
	(if r
	    (let ((run-list (%test-runner-run-list r)))
	      (cond ((null? rest)
		     (%test-runner-run-list! r (reverse! run-list))
		     (first)) ;; actually apply procedure thunk
		    (else
		     (%test-runner-run-list!
		      r
		      (if (eq? run-list #t) (list first) (cons first run-list)))
		     (apply test-apply rest)
		     (%test-runner-run-list! r run-list))))
	    (let ((r (test-runner-create)))
	      (test-with-runner r (apply test-apply first rest))
	      ((test-runner-on-final r) r))))))

(define-syntax test-with-runner
  (syntax-rules ()
    ((test-with-runner runner form ...)
     (let ((saved-runner (test-runner-current)))
       (dynamic-wind
           (lambda () (test-runner-current runner))
           (lambda () form ...)
           (lambda () (test-runner-current saved-runner)))))))

;;; Predicates

(define (%test-match-nth n count)
  (let ((i 0))
    (lambda (runner)
      (set! i (+ i 1))
      (and (>= i n) (< i (+ n count))))))

(define-syntax test-match-nth
  (syntax-rules ()
    ((test-match-nth n)
     (test-match-nth n 1))
    ((test-match-nth n count)
     (%test-match-nth n count))))

(define (%test-match-all . pred-list)
  (lambda (runner)
    (let ((result #t))
      (let loop ((l pred-list))
	(if (null? l)
	    result
	    (begin
	      (if (not ((car l) runner))
		  (set! result #f))
	      (loop (cdr l))))))))
  
(define-syntax test-match-all
  (syntax-rules ()
    ((test-match-all pred ...)
     (%test-match-all (%test-as-specifier pred) ...))))

(define (%test-match-any . pred-list)
  (lambda (runner)
    (let ((result #f))
      (let loop ((l pred-list))
	(if (null? l)
	    result
	    (begin
	      (if ((car l) runner)
		  (set! result #t))
	      (loop (cdr l))))))))
  
(define-syntax test-match-any
  (syntax-rules ()
    ((test-match-any pred ...)
     (%test-match-any (%test-as-specifier pred) ...))))

;; Coerce to a predicate function:
(define (%test-as-specifier specifier)
  (cond ((procedure? specifier) specifier)
	((integer? specifier) (test-match-nth 1 specifier))
	((string? specifier) (test-match-name specifier))
	(else
	 (error "not a valid test specifier"))))

(define-syntax test-skip
  (syntax-rules ()
    ((test-skip pred ...)
     (let ((runner (test-runner-get)))
       (%test-runner-skip-list! runner
				  (cons (test-match-all (%test-as-specifier pred)  ...)
					(%test-runner-skip-list runner)))))))

(define-syntax test-expect-fail
  (syntax-rules ()
    ((test-expect-fail pred ...)
     (let ((runner (test-runner-get)))
       (%test-runner-fail-list! runner
				  (cons (test-match-all (%test-as-specifier pred)  ...)
					(%test-runner-fail-list runner)))))))

(define (test-match-name name)
  (lambda (runner)
    (equal? name (test-runner-test-name runner))))

(define (test-read-eval-string string)
  (let* ((port (open-input-string string))
	 (form (read port)))
    (if (eof-object? (read-char port))
	(eval form)
	(cond-expand
	 (srfi-23 (error "(not at eof)"))
	 (else "error")))))

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1.1: Type: text/plain, Size: 1655 bytes --]

I've attached diff of 2007 testing.scm.

2012/4/21 Per Bothner <per@bothner.com>
>
> I'm going to look at the patch in detail, but before I do, a question:
> Why is your srfi-64.scm.gz "for Guile, Chicken and Gambit" so very
> different from the reference implementation with your patch applied?
>

I just mean that I had tested my srfi-64.scm on Guile, Chicken and Gambit.
srfi-64.scm pass the srfi-64-test.scm on Guile and Chicken.
There is only one fail on Gambit and I suspect dynamic-wind bug of Gambit
is cause of that.

The patched testing.scm pass the srfi-64-test.scm on Guile.
But I'm not sure it to pass the srfi-64-test.scm on Chicken or Gambit.

You mention "the order and style of definitions".  Could you be more
> specific?  I can certainly re-order definitions if that will help,
> but I'd like to understand why.  And I'd prefer to re-order them myself.
> For example: "macro x needs to be moved before function y because of z".
>

For on Guile, test-with-runner should be defined before test-apply
because test-apply use test-with-runner.

I saw compile errors when I compiled my srfi-64.scm on Chicken.
Of course, srfi-64.scm had passed the srfi-64-test.scm on Guile but can't
be compiled then.
So, I re-ordered definitions in srfi-64.scm and make it pass.


> And what is the problem with the "style"?  A module issue?
>

No, style is not a problem; style is just style.

Humm... like these;
test-result-ref is a procedure in srfi-64.scm but a macro in testing.scm.
test-match-any, test-match-all, test-skip, test-expect-fail
and %test-should-execute are defined #f and set! later.
test-on-final-simple has return value.
and so on...

[-- Attachment #1.2: Type: text/html, Size: 2504 bytes --]

[-- Attachment #2: testing.patch.gz --]
[-- Type: application/x-gzip, Size: 3613 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Ludovic Courtès]

Hi,

Per Bothner <per@bothner.com> skribis:

> I think it would be great to get SRFI-64 into Guile.

Me too.

FWIW, I’ve been using an almost-unmodified version in several projects:

  http://git.savannah.gnu.org/cgit/libchop.git/tree/guile2/srfi

The only changes compared to the reference implementations are minor
improvements:

  http://git.savannah.gnu.org/cgit/libchop.git/log/guile2/srfi/srfi-64.upstream.scm

If you add them upstream, then I’m happy to add SRFI-64 in Guile.  :-)

Besides, do you have a Texinfo version of the documentation?

Thanks,
Ludo’.

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1: Type: text/plain, Size: 1437 bytes --]

Hi, Ludo’;

Your implementation fails srfi-64-test.scm, a test suite for the SRFI 64.

Per:
I realize the test-error of the reference implementation has a bug;
It calls %test-error like this - (test-assert (%test-error etype expr))
but %test-error needs three arguments - (%test-error r etype expr) !!
I think you may fix it.
Humm... in %test-error (and srfi-34 srfi-35) case, (equal? type #t) is a
typo of (equal? etype #t), I think.

Ludo’:
"Store the test log in UTF-8" is a good idea.
I don't know "Display a backtrace upon error."
In my implementation on Guile and Per's reference implementation on
Kawa, actual-error is loged if exception occurs like this;
  Test begin:
    test-name: "3.3. test-begin with mismatched test-end"
    source-file: "srfi-64-test.scm"
    source-line: 236
    source-form: (test-error "3.3. test-begin with mismatched test-end" #t
(triv-runner (lambda () (test-begin "a") (test-assert "b" #t) (test-end
"x"))))
  Test end:
    result-kind: pass
    actual-error: (misc-error #f "~A" ("bad end grojup name a but expected
x") #f)
    expected-error: #t

2012/4/21 Ludovic Courtès <ludo@gnu.org>
>
> Per Bothner <per@bothner.com> skribis:
>
> > I think it would be great to get SRFI-64 into Guile.
>
> Me too.
>
> FWIW, I’ve been using an almost-unmodified version in several projects:
>
>  http://git.savannah.gnu.org/cgit/libchop.git/tree/guile2/srfi
>

[-- Attachment #2: Type: text/html, Size: 2233 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Ludovic Courtès]

Hello,

Sunjoong Lee <sunjoong@gmail.com> skribis:

> Your implementation fails srfi-64-test.scm, a test suite for the SRFI 64.

Oh, which ones?  This is essentially the reference implementation, so it
shouldn’t fail.  But perhaps my copy of srfi-64.scm is older than
srfi-64-test.scm?

> I don't know "Display a backtrace upon error."
> In my implementation on Guile and Per's reference implementation on
> Kawa, actual-error is loged if exception occurs like this;
>   Test begin:
>     test-name: "3.3. test-begin with mismatched test-end"
>     source-file: "srfi-64-test.scm"
>     source-line: 236
>     source-form: (test-error "3.3. test-begin with mismatched test-end" #t
> (triv-runner (lambda () (test-begin "a") (test-assert "b" #t) (test-end
> "x"))))
>   Test end:
>     result-kind: pass
>     actual-error: (misc-error #f "~A" ("bad end grojup name a but expected
> x") #f)
>     expected-error: #t

Indeed, that’s better than what I’m getting.  I must be using an old
version of srfi-64.scm.

Thanks,
Ludo’.

Re: SRFI-64 implementation for Guile 2.0

[Sunjoong Lee]

[-- Attachment #1: Type: text/plain, Size: 5669 bytes --]

Hi, Ludo’;

A srfi-64-test.scm file is a test suite for the SRFI 64 and you can get it
from http://srfi.schemers.org/srfi-64/srfi-64-test.scm .

51 expected passes and 2 expected failures are normal:
  $ guile -L /home/sunjoong/guile/site --use-srfi=64 srfi-64-test.scm
%%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI 64
- Meta-Test Suite.log")
  # of expected passes      51
  # of expected failures    2

In above example, /home/sunjoong/guile/site directory is where srfi
directory be in residence and srfi directory contains SRFI
64 implementation.
If it display unexpected(!!) failure, something's wrong.

2012/4/22 Ludovic Courtès <ludo@gnu.org>

> Hello,
>
> Sunjoong Lee <sunjoong@gmail.com> skribis:
>
> > Your implementation fails srfi-64-test.scm, a test suite for the SRFI 64.
>
> Oh, which ones?  This is essentially the reference implementation, so it
> shouldn’t fail.  But perhaps my copy of srfi-64.scm is older than
> srfi-64-test.scm?
>
>
The reference implementation has a bug at test-error macro and it cause
syntax error like this:
  $ guile -L /home/sunjoong/guile/site --use-srfi=64 srfi-64-test.scm
  ;;; ERROR: Syntax error:
  ;;; /home/sunjoong/guile/test/srfi-64-test.scm:186:4: source expression
failed to match any pattern in form (%test-error #t (vector-ref (quote #(1
2)) 9))
  %%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI
64 - Meta-Test Suite.log")

I've noticed that and sent a patch to Per.
Even after fixing this bug, there are some problems;

First, test-error use %test-error but %test-error sets result-kind to skip.
So, the reference implementation fails the test suite for the SRFI 64
whenever not on kawa or mzscheme.
Though it fails srfi-64-test.scm, you may use test-error macro after fixing
above a bug but...

Second, test-apply uses test-with-runner but test-with-runner defined
after test-apply.
Third, test-group is not exported.

At last, you're using make-stack, a Guile's debugging facility.
I think it makes a problem more complex;

  $ guile -L /home/sunjoong/guile/site --use-srfi=64 srfi-64-test.scm
  %%%% Starting test SRFI 64 - Meta-Test Suite  (Writing full log to "SRFI
64 - Meta-Test Suite.log")
  In ice-9/boot-9.scm:
   149: 18 [catch #t #<catch-closure 8674460> ...]
   157: 17 [#<procedure 863d8c0 ()>]
  In unknown file:
     ?: 16 [catch-closure]
  In ice-9/boot-9.scm:
    63: 15 [call-with-prompt prompt0 ...]
  In ice-9/eval.scm:
   407: 14 [eval # #]
  In ice-9/boot-9.scm:
  2111: 13 [save-module-excursion #<procedure 8c45840 at
ice-9/boot-9.scm:3646:3 ()>]
  3653: 12 [#<procedure 8c45840 at ice-9/boot-9.scm:3646:3 ()>]
  In unknown file:
     ?: 11 [load-compiled/vm
"/home/sunjoong/.cache/guile/ccache/2.0-LE-4-2.0/home/sunjoong/guile/test/srfi-64-test.scm.go"]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   147: 10 [#<procedure 90dd820 ()>]
  In ice-9/boot-9.scm:
   149: 9 [catch #t ...]
   157: 8 [#<procedure 8ad41b8 ()>]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
    90: 7 [triv-runner #<procedure 91247e0 at
/home/sunjoong/guile/test/srfi-64-test.scm:150:14 ()>]
   150: 6 [#<procedure 91247e0 at
/home/sunjoong/guile/test/srfi-64-test.scm:150:14 ()>]
  In ice-9/boot-9.scm:
   149: 5 [catch #t ...]
   157: 4 [#<procedure 8ad4190 ()>]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   145: 3 [choke]
  In ice-9/boot-9.scm:
   102: 2 [#<procedure 90981a0 at ice-9/boot-9.scm:97:6 (thrown-k . args)>
out-of-range ...]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   150: 1 [#<procedure 9124800 at
/home/sunjoong/guile/test/srfi-64-test.scm:150:25 (key . args)>
out-of-range ...]
  In unknown file:
     ?: 0 [make-stack #t]
  FAIL 2.1.1. Baseline test; PASS with no optional args
  FAIL 2.1.2. Baseline test; FAIL with no optional args
  FAIL 2.1.3. PASS with a test name and error type
  In ice-9/boot-9.scm:
   149: 18 [catch #t #<catch-closure 8674460> ...]
   157: 17 [#<procedure 863d8c0 ()>]
  In unknown file:
     ?: 16 [catch-closure]
  In ice-9/boot-9.scm:
    63: 15 [call-with-prompt prompt0 ...]
  In ice-9/eval.scm:
   407: 14 [eval # #]
  In ice-9/boot-9.scm:
  2111: 13 [save-module-excursion #<procedure 8c45840 at
ice-9/boot-9.scm:3646:3 ()>]
  3653: 12 [#<procedure 8c45840 at ice-9/boot-9.scm:3646:3 ()>]
  In unknown file:
     ?: 11 [load-compiled/vm
"/home/sunjoong/.cache/guile/ccache/2.0-LE-4-2.0/home/sunjoong/guile/test/srfi-64-test.scm.go"]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   607: 10 [#<procedure 90dd820 ()>]
  In ice-9/boot-9.scm:
   149: 9 [catch #t ...]
   157: 8 [#<procedure 9668280 ()>]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
    90: 7 [triv-runner #<procedure 8c54f00 at
/home/sunjoong/guile/test/srfi-64-test.scm:610:13 ()>]
   613: 6 [#<procedure 8c54f00 at
/home/sunjoong/guile/test/srfi-64-test.scm:610:13 ()>]
  In ice-9/boot-9.scm:
   149: 5 [catch #t ...]
   157: 4 [#<procedure 9668230 ()>]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   145: 3 [choke]
  In ice-9/boot-9.scm:
   102: 2 [#<procedure 92b9660 at ice-9/boot-9.scm:97:6 (thrown-k . args)>
out-of-range ...]
  In /home/sunjoong/guile/test/srfi-64-test.scm:
   613: 1 [#<procedure 8c54fb0 at
/home/sunjoong/guile/test/srfi-64-test.scm:613:15 (key . args)>
out-of-range ...]
  In unknown file:
     ?: 0 [make-stack #t]
  # of expected passes      50
  # of expected failures    2
  # of unexpected failures  3

In above example, 3 unexpected failures are because of %test-error, I think.
But there are so many backtraces(?).

[-- Attachment #2: Type: text/html, Size: 7741 bytes --]

Re: SRFI-64 implementation for Guile 2.0

[Per Bothner]

I don't think we ever resolved this.  It would be great if we could
get good support for Guile (and other Schemes).  The way I like to
work (and this is standard in every well-managed Free Software project)
is I don't want to see your updated code; I want to see a patch
(created using 'diff -u' or the equivalent).  I prefer a separate
for for each problem you're fixing or enhancement you're making,
so I can evaluate each patch by itself, and perhaps consider
alternative solutions.

The latest version of SRFI-64 (as checked into the Kawa resolitory) is here:
http://sourceware.org/viewvc/kawa/trunk/gnu/kawa/slib/testing.scm?view=co

It may be easier to create a patch if you check out the Kawa sources - see
this link for instructions 
http://www.gnu.org/software/kawa/Getting-Kawa.html
-- 
	--Per Bothner
per@bothner.com   http://per.bothner.com/