~ruther/guix-local: Update SRFI-64 to the latest upstream version.

2 files changed, 132 insertions(+), 70 deletions(-)

M srfi/srfi-64.scm
M srfi/srfi-64.upstream.scm

M srfi/srfi-64.scm => srfi/srfi-64.scm +3 -1

@@ 4,7 4,7 @@
             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-runner-group-path test-group 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


@@ 35,5 35,7 @@
             test-on-final-simple test-on-test-end-simple
             test-on-final-simple))
 
+(cond-expand-provide (current-module) '(srfi-64))
+
 ;; Load Per Bothner's original SRFI-64 implementation.
 (load-from-path "srfi/srfi-64.upstream.scm")

M srfi/srfi-64.upstream.scm => srfi/srfi-64.upstream.scm +129 -69

@@ 1,4 1,8 @@
-;; Copyright (c) 2005, 2006 Per Bothner
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; 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


@@ 23,8 27,14 @@
 (cond-expand
  (chicken
   (require-extension syntax-case))
- (guile
+ (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
 	       (srfi srfi-39)))
  (sisc


@@ 57,7 67,7 @@
  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-runner-group-path test-group 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


@@ 108,7 118,7 @@
 		(> (vector-length obj) 1)
 		(eq (vector-ref obj 0) %test-runner-cookie)))
 	 (define (alloc)
-	   (let ((runner (make-vector 22)))
+	   (let ((runner (make-vector 23)))
 	     (vector-set! runner 0 %test-runner-cookie)
 	     runner))
 	 (begin


@@ 156,19 166,20 @@
 )
 
 (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 '()))
+  (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)))


@@ 232,7 243,7 @@
 	 (else #t)))
     r))
 
-(define (%test-specificier-matches spec runner)
+(define (%test-specifier-matches spec runner)
   (spec runner))
 
 (define (test-runner-create)


@@ 243,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)))))))
 


@@ 311,12 322,6 @@
 		   (log-file
 		    (cond-expand (mzscheme
 				  (open-output-file log-file-name 'truncate/replace))
-                                 (guile-2
-                                  (with-fluids ((%default-port-encoding
-                                                 "UTF-8"))
-                                    (let ((p (open-output-file log-file-name)))
-                                      (setvbuf p _IOLBF)
-                                      p)))
 				 (else (open-output-file log-file-name)))))
 	      (display "%%%% Starting test " log-file)
 	      (display suite-name log-file)


@@ 469,7 474,7 @@
 	  (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))))))
+	  (if source-form (%test-write-result1 source-form log))))))
 
 (define-syntax test-result-ref
   (syntax-rules ()


@@ 570,9 575,10 @@
       ((%test-evaluate-with-catch test-expression)
        (catch #t
          (lambda () test-expression)
-         (lambda (key . args) #f)
          (lambda (key . args)
-           (display-backtrace (make-stack #t) (current-error-port))))))))
+           (test-result-set! (test-runner-current) 'actual-error
+                             (cons key args))
+           #f))))))
  (kawa
   (define-syntax %test-evaluate-with-catch
     (syntax-rules ()


@@ 609,12 615,27 @@
    (kawa
     (define (%test-syntax-file form)
       (syntax-source form))))
-  (define-for-syntax (%test-source-line2 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)))))
+ (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)
     '())))


@@ 645,10 666,16 @@
 			   (%test-on-test-end r (comp exp res)))))
 		   (%test-report-result)))))
 
-(define (%test-approximimate= error)
+(define (%test-approximate= error)
   (lambda (value expected)
-    (and (>= value (- expected error))
-         (<= value (+ expected error)))))
+    (let ((rval (real-part value))
+          (ival (imag-part value))
+          (rexp (real-part expected))
+          (iexp (imag-part expected)))
+      (and (>= rval (- rexp error))
+           (>= ival (- iexp error))
+           (<= rval (+ rexp error))
+           (<= ival (+ iexp error))))))
 
 (define-syntax %test-comp1body
   (syntax-rules ()


@@ 662,12 689,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 703,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))


@@ 688,8 715,8 @@
 	  (let* ((r (test-runner-get)))
 	    (test-result-alist! r line)
 	    (%test-comp1body r expr)))))))
-  (define-for-syntax (%test-comp2 comp x)
-    (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) ()
+  (define (%test-comp2 comp x)
+    (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,18 736,18 @@
     (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))
 	       (name tname))
 	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r (%test-approximimate= error) expected expr))))
+	  (%test-comp2body r (%test-approximate= 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))))))))
+	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
  (else
   (define-syntax test-end
     (syntax-rules ()


@@ 765,16 792,30 @@
   (define-syntax test-approximate
     (syntax-rules ()
       ((test-approximate tname expected expr error)
-       (%test-comp2 (%test-approximimate= error) tname expected expr))
+       (%test-comp2 (%test-approximate= error) tname expected expr))
       ((test-approximate expected expr error)
-       (%test-comp2 (%test-approximimate= error) expected expr))))))
+       (%test-comp2 (%test-approximate= 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)))))))
+       (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 ()


@@ 791,23 832,34 @@
  (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)
-       (let ()
-	 (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))))))))
+       (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 ()


@@ 816,15 868,15 @@
 		   (and (condition? ex) (condition-has-type? ex etype)))
 		  ((procedure? etype)
 		   (etype ex))
-		  ((equal? type #t)
+		  ((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 ()


@@ 835,11 887,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))


@@ 860,11 912,17 @@
   (define-syntax test-error
     (syntax-rules ()
       ((test-error name etype expr)
-       (test-assert name (%test-error etype expr)))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r `((test-name . ,name)))
+         (%test-error r etype expr)))
       ((test-error etype expr)
-       (test-assert (%test-error etype expr)))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r etype expr)))
       ((test-error expr)
-       (test-assert (%test-error #t expr)))))))
+       (let ((r (test-runner-get)))
+         (test-result-alist! r '())
+         (%test-error r #t expr)))))))
 
 (define (test-apply first . rest)
   (if (test-runner? first)


@@ 873,7 931,7 @@
 	(if r
 	    (let ((run-list (%test-runner-run-list r)))
 	      (cond ((null? rest)
-		     (%test-runner-run-list! r (reverse! run-list))
+		     (%test-runner-run-list! r (reverse run-list))
 		     (first)) ;; actually apply procedure thunk
 		    (else
 		     (%test-runner-run-list!


@@ 973,7 1031,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")))))