[PATCH] Changes to SRFI-64 testing.scm to support Guile 2, etc.

[Mark H Weaver <mhw@netris.org>]

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

Hi Per,

I've modified testing.scm to fully support Guile 2.  It passes all tests
of srfi-64-test.scm, except for the two expected failures.  (What's the
story with those expected failures, btw?  Do they pass on any system?)

A few notes:

* Guile 2's syntax-case macro system does not tolerate bare symbols in
  the output of macro transformers, but the syntax-case macros in
  testing.scm generate bare symbols.  I fixed this by changing several
  instances of 'quote to (syntax quote), and also by using
  'datum->syntax' in Guile-2's implementation of '%test-source-line2'.

* I noticed that three of the implementations of '%test-error' were
  incorrect in the following respect: they should return #f if no error
  occurs, but instead they would return the result of evaluating the
  test expression.  To fix this, I added '#f' after 'expr' in several
  places.

* In 'test-read-eval-string', you call 'eval' with only one argument,
  but R5RS, R6RS, and R7RS all specify that 'eval' takes two arguments.
  Guile's 'eval' requires two arguments.

Anyway, I've attached a patch with my changes to testing.scm.

    Regards,
      Mark



[-- Attachment #2: Changes to SRFI-64 testing.scm to support Guile 2, etc. --]
[-- Type: text/x-patch, Size: 6266 bytes --]

--- testing.scm-ORIG	2014-01-28 23:23:45.443513698 -0500
+++ testing.scm	2014-01-29 03:33:40.647991235 -0500
@@ -2,6 +2,7 @@
 ;; Added "full" support for Chicken, Gauche, Guile and SISC.
 ;;   Alex Shinn, Copyright (c) 2005.
 ;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
 ;;
 ;; Permission is hereby granted, free of charge, to any person
 ;; obtaining a copy of this software and associated documentation
@@ -26,6 +27,12 @@
 (cond-expand
  (chicken
   (require-extension syntax-case))
+ (guile-2
+  (use-modules (srfi srfi-9)
+               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
+               ;; with either Guile's native exceptions or R6RS exceptions.
+               ;;(srfi srfi-34) (srfi srfi-35)
+               (srfi srfi-39)))
  (guile
   (use-modules (ice-9 syncase) (srfi srfi-9)
 	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
@@ -236,7 +243,7 @@
 	 (else #t)))
     r))
 
-(define (%test-specificier-matches spec runner)
+(define (%test-specifier-matches spec runner)
   (spec runner))
 
 (define (test-runner-create)
@@ -247,7 +254,7 @@
     (let loop ((l list))
       (cond ((null? l) result)
 	    (else
-	     (if (%test-specificier-matches (car l) runner)
+	     (if (%test-specifier-matches (car l) runner)
 		 (set! result #t))
 	     (loop (cdr l)))))))
 
@@ -609,6 +616,21 @@
 	   (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)))))
+ (guile-2
+  (define (%test-source-line2 form)
+    (let* ((src-props (syntax-source form))
+           (file (and src-props (assq-ref src-props 'filename)))
+           (line (and src-props (assq-ref src-props 'line)))
+           (file-alist (if file
+                           `((source-file . ,file))
+                           '()))
+           (line-alist (if line
+                           `((source-line . ,(+ line 1)))
+                           '())))
+      (datum->syntax (syntax here)
+                     `((source-form . ,(syntax->datum form))
+                       ,@file-alist
+                       ,@line-alist)))))
  (else
   (define (%test-source-line2 form)
     '())))
@@ -662,12 +684,12 @@
        (%test-report-result)))))
 
 (cond-expand
- ((or kawa mzscheme)
+ ((or kawa mzscheme guile-2)
   ;; 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))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac suite-name) line)
 	 (syntax
 	  (%test-end suite-name line)))
@@ -676,7 +698,7 @@
 	  (%test-end #f line))))))
   (define-syntax test-assert
     (lambda (x)
-      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac tname expr) line)
 	 (syntax
 	  (let* ((r (test-runner-get))
@@ -689,7 +711,7 @@
 	    (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) ()
+    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
       (((mac tname expected expr) line comp)
        (syntax
 	(let* ((r (test-runner-get))
@@ -709,7 +731,7 @@
     (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))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
       (((mac tname expected expr error) line)
        (syntax
 	(let* ((r (test-runner-get))
@@ -774,7 +796,21 @@
   (define-syntax %test-error
     (syntax-rules ()
       ((%test-error r etype expr)
-       (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t)))))))
+       (cond ((%test-on-test-begin r)
+              (let ((et etype))
+                (test-result-set! r 'expected-error et)
+                (%test-on-test-end r
+                                   (catch #t
+                                     (lambda ()
+                                       (test-result-set! r 'actual-value expr)
+                                       #f)
+                                     (lambda (key . args)
+                                       ;; TODO: decide how to specify expected
+                                       ;; error types for Guile.
+                                       (test-result-set! r 'actual-error
+                                                         (cons key args))
+                                       #t)))
+                (%test-report-result))))))))
  (mzscheme
   (define-syntax %test-error
     (syntax-rules ()
@@ -830,12 +866,12 @@
 		  ((equal? etype #t)
 		   #t)
 		  (else #t))
-	      expr))))))
+	      expr #f))))))
  (srfi-34
   (define-syntax %test-error
     (syntax-rules ()
       ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex (else #t)) expr))))))
+       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
  (else
   (define-syntax %test-error
     (syntax-rules ()
@@ -846,11 +882,11 @@
 	 (%test-report-result)))))))
 
 (cond-expand
- ((or kawa mzscheme)
+ ((or kawa mzscheme guile-2)
 
   (define-syntax test-error
     (lambda (x)
-      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
+      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 	(((mac tname etype expr) line)
 	 (syntax
 	  (let* ((r (test-runner-get))
@@ -987,7 +1023,9 @@
   (let* ((port (open-input-string string))
 	 (form (read port)))
     (if (eof-object? (read-char port))
-	(eval form)
+	(cond-expand
+	 (guile (eval form (current-module)))
+	 (else (eval form)))
 	(cond-expand
 	 (srfi-23 (error "(not at eof)"))
 	 (else "error")))))