nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Update SRFI-64 to the latest upstream version. 

* srfi/srfi-64.scm: Export 'test-group'.  Call 'cond-expand-provide'.
* srfi/srfi-64.upstream.scm: Update to the latest upstream version.
This commit is contained in:
Mark H Weaver 2014-02-24 16:10:40 -05:00
parent c4dc4466d6
commit 8fade76f5d
2 changed files with 132 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
srfi/srfi-64.scm
View File

@ -4,7 +4,7 @@
test-approximate test-assert test-error test-apply test-with-runner test-approximate test-assert test-error test-apply test-with-runner
test-match-nth test-match-all test-match-any test-match-name test-match-nth test-match-all test-match-any test-match-name
test-skip test-expect-fail test-read-eval-string 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-ref test-result-set! test-result-clear test-result-remove
test-result-kind test-passed? test-result-kind test-passed?
test-log-to-file test-log-to-file
@ -35,5 +35,7 @@
test-on-final-simple test-on-test-end-simple test-on-final-simple test-on-test-end-simple
test-on-final-simple)) test-on-final-simple))
(cond-expand-provide (current-module) '(srfi-64))
;; Load Per Bothner's original SRFI-64 implementation. ;; Load Per Bothner's original SRFI-64 implementation.
(load-from-path "srfi/srfi-64.upstream.scm") (load-from-path "srfi/srfi-64.upstream.scm")

198
srfi/srfi-64.upstream.scm
View File

@ -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 ;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation ;; obtaining a copy of this software and associated documentation
@ -23,8 +27,14 @@
(cond-expand (cond-expand
(chicken (chicken
(require-extension syntax-case)) (require-extension syntax-case))
(guile (guile-2
(use-modules (srfi srfi-9) (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-34) (srfi srfi-35) - not in Guile 1.6.7
(srfi srfi-39))) (srfi srfi-39)))
(sisc (sisc
@ -57,7 +67,7 @@
test-approximate test-assert test-error test-apply test-with-runner test-approximate test-assert test-error test-apply test-with-runner
test-match-nth test-match-all test-match-any test-match-name test-match-nth test-match-all test-match-any test-match-name
test-skip test-expect-fail test-read-eval-string 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-ref test-result-set! test-result-clear test-result-remove
test-result-kind test-passed? test-result-kind test-passed?
test-log-to-file test-log-to-file
@ -108,7 +118,7 @@
(> (vector-length obj) 1) (> (vector-length obj) 1)
(eq (vector-ref obj 0) %test-runner-cookie))) (eq (vector-ref obj 0) %test-runner-cookie)))
(define (alloc) (define (alloc)
(let ((runner (make-vector 22))) (let ((runner (make-vector 23)))
(vector-set! runner 0 %test-runner-cookie) (vector-set! runner 0 %test-runner-cookie)
runner)) runner))
(begin (begin
@ -156,19 +166,20 @@
) )
(define (test-runner-reset runner) (define (test-runner-reset runner)
(test-runner-pass-count! runner 0) (test-result-alist! runner '())
(test-runner-fail-count! runner 0) (test-runner-pass-count! runner 0)
(test-runner-xpass-count! runner 0) (test-runner-fail-count! runner 0)
(test-runner-xfail-count! runner 0) (test-runner-xpass-count! runner 0)
(test-runner-skip-count! runner 0) (test-runner-xfail-count! runner 0)
(%test-runner-total-count! runner 0) (test-runner-skip-count! runner 0)
(%test-runner-count-list! runner '()) (%test-runner-total-count! runner 0)
(%test-runner-run-list! runner #t) (%test-runner-count-list! runner '())
(%test-runner-skip-list! runner '()) (%test-runner-run-list! runner #t)
(%test-runner-fail-list! runner '()) (%test-runner-skip-list! runner '())
(%test-runner-skip-save! runner '()) (%test-runner-fail-list! runner '())
(%test-runner-fail-save! runner '()) (%test-runner-skip-save! runner '())
(test-runner-group-stack! runner '())) (%test-runner-fail-save! runner '())
(test-runner-group-stack! runner '()))
(define (test-runner-group-path runner) (define (test-runner-group-path runner)
(reverse (test-runner-group-stack runner))) (reverse (test-runner-group-stack runner)))
@ -232,7 +243,7 @@
(else #t))) (else #t)))
r)) r))
(define (%test-specificier-matches spec runner) (define (%test-specifier-matches spec runner)
(spec runner)) (spec runner))
(define (test-runner-create) (define (test-runner-create)
@ -243,7 +254,7 @@
(let loop ((l list)) (let loop ((l list))
(cond ((null? l) result) (cond ((null? l) result)
(else (else
(if (%test-specificier-matches (car l) runner) (if (%test-specifier-matches (car l) runner)
(set! result #t)) (set! result #t))
(loop (cdr l))))))) (loop (cdr l)))))))
@ -311,12 +322,6 @@
(log-file (log-file
(cond-expand (mzscheme (cond-expand (mzscheme
(open-output-file log-file-name 'truncate/replace)) (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))))) (else (open-output-file log-file-name)))))
(display "%%%% Starting test " log-file) (display "%%%% Starting test " log-file)
(display suite-name log-file) (display suite-name log-file)
@ -469,7 +474,7 @@
(if test-name (%test-write-result1 test-name log)) (if test-name (%test-write-result1 test-name log))
(if source-file (%test-write-result1 source-file log)) (if source-file (%test-write-result1 source-file log))
(if source-line (%test-write-result1 source-line 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 (define-syntax test-result-ref
(syntax-rules () (syntax-rules ()
@ -570,9 +575,10 @@
((%test-evaluate-with-catch test-expression) ((%test-evaluate-with-catch test-expression)
(catch #t (catch #t
(lambda () test-expression) (lambda () test-expression)
(lambda (key . args) #f)
(lambda (key . args) (lambda (key . args)
(display-backtrace (make-stack #t) (current-error-port)))))))) (test-result-set! (test-runner-current) 'actual-error
(cons key args))
#f))))))
(kawa (kawa
(define-syntax %test-evaluate-with-catch (define-syntax %test-evaluate-with-catch
(syntax-rules () (syntax-rules ()
@ -609,12 +615,27 @@
(kawa (kawa
(define (%test-syntax-file form) (define (%test-syntax-file form)
(syntax-source form)))) (syntax-source form))))
(define-for-syntax (%test-source-line2 form) (define (%test-source-line2 form)
(let* ((line (syntax-line form)) (let* ((line (syntax-line form))
(file (%test-syntax-file form)) (file (%test-syntax-file form))
(line-pair (if line (list (cons 'source-line line)) '()))) (line-pair (if line (list (cons 'source-line line)) '())))
(cons (cons 'source-form (syntax-object->datum form)) (cons (cons 'source-form (syntax-object->datum form))
(if file (cons (cons 'source-file file) line-pair) line-pair))))) (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 (else
(define (%test-source-line2 form) (define (%test-source-line2 form)
'()))) '())))
@ -645,10 +666,16 @@
(%test-on-test-end r (comp exp res))))) (%test-on-test-end r (comp exp res)))))
(%test-report-result))))) (%test-report-result)))))
(define (%test-approximimate= error) (define (%test-approximate= error)
(lambda (value expected) (lambda (value expected)
(and (>= value (- expected error)) (let ((rval (real-part value))
(<= value (+ expected error))))) (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 (define-syntax %test-comp1body
(syntax-rules () (syntax-rules ()
@ -662,12 +689,12 @@
(%test-report-result))))) (%test-report-result)))))
(cond-expand (cond-expand
((or kawa mzscheme) ((or kawa mzscheme guile-2)
;; Should be made to work for any Scheme with syntax-case ;; Should be made to work for any Scheme with syntax-case
;; However, I haven't gotten the quoting working. FIXME. ;; However, I haven't gotten the quoting working. FIXME.
(define-syntax test-end (define-syntax test-end
(lambda (x) (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) (((mac suite-name) line)
(syntax (syntax
(%test-end suite-name line))) (%test-end suite-name line)))
@ -676,7 +703,7 @@
(%test-end #f line)))))) (%test-end #f line))))))
(define-syntax test-assert (define-syntax test-assert
(lambda (x) (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) (((mac tname expr) line)
(syntax (syntax
(let* ((r (test-runner-get)) (let* ((r (test-runner-get))
@ -688,8 +715,8 @@
(let* ((r (test-runner-get))) (let* ((r (test-runner-get)))
(test-result-alist! r line) (test-result-alist! r line)
(%test-comp1body r expr))))))) (%test-comp1body r expr)))))))
(define-for-syntax (%test-comp2 comp x) (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) (((mac tname expected expr) line comp)
(syntax (syntax
(let* ((r (test-runner-get)) (let* ((r (test-runner-get))
@ -709,18 +736,18 @@
(lambda (x) (%test-comp2 (syntax equal?) x))) (lambda (x) (%test-comp2 (syntax equal?) x)))
(define-syntax test-approximate ;; FIXME - needed for non-Kawa (define-syntax test-approximate ;; FIXME - needed for non-Kawa
(lambda (x) (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) (((mac tname expected expr error) line)
(syntax (syntax
(let* ((r (test-runner-get)) (let* ((r (test-runner-get))
(name tname)) (name tname))
(test-result-alist! r (cons (cons 'test-name tname) line)) (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) (((mac expected expr error) line)
(syntax (syntax
(let* ((r (test-runner-get))) (let* ((r (test-runner-get)))
(test-result-alist! r line) (test-result-alist! r line)
(%test-comp2body r (%test-approximimate= error) expected expr)))))))) (%test-comp2body r (%test-approximate= error) expected expr))))))))
(else (else
(define-syntax test-end (define-syntax test-end
(syntax-rules () (syntax-rules ()
@ -765,16 +792,30 @@
(define-syntax test-approximate (define-syntax test-approximate
(syntax-rules () (syntax-rules ()
((test-approximate tname expected expr error) ((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-approximate expected expr error)
(%test-comp2 (%test-approximimate= error) expected expr)))))) (%test-comp2 (%test-approximate= error) expected expr))))))
(cond-expand (cond-expand
(guile (guile
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (syntax-rules ()
((%test-error r etype expr) ((%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 (mzscheme
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (syntax-rules ()
@ -791,23 +832,34 @@
(kawa (kawa
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (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) ((%test-error r etype expr)
(let () (if (%test-on-test-begin r)
(if (%test-on-test-begin r) (let ((et etype))
(let ((et etype)) (test-result-set! r 'expected-error et)
(test-result-set! r 'expected-error et) (%test-on-test-end r
(%test-on-test-end r (try-catch
(try-catch (let ()
(let () (test-result-set! r 'actual-value expr)
(test-result-set! r 'actual-value expr) #f)
#f) (ex <java.lang.Throwable>
(ex <java.lang.Throwable> (test-result-set! r 'actual-error ex)
(test-result-set! r 'actual-error ex) (cond ((and (instance? et <gnu.bytecode.ClassType>)
(cond ((and (instance? et <gnu.bytecode.ClassType>) (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) (instance? ex et))
(instance? ex et)) (else #t)))))
(else #t))))) (%test-report-result)))))))
(%test-report-result))))))))
((and srfi-34 srfi-35) ((and srfi-34 srfi-35)
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (syntax-rules ()
@ -816,15 +868,15 @@
(and (condition? ex) (condition-has-type? ex etype))) (and (condition? ex) (condition-has-type? ex etype)))
((procedure? etype) ((procedure? etype)
(etype ex)) (etype ex))
((equal? type #t) ((equal? etype #t)
#t) #t)
(else #t)) (else #t))
expr)))))) expr #f))))))
(srfi-34 (srfi-34
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (syntax-rules ()
((%test-error r etype expr) ((%test-error r etype expr)
(%test-comp1body r (guard (ex (else #t)) expr)))))) (%test-comp1body r (guard (ex (else #t)) expr #f))))))
(else (else
(define-syntax %test-error (define-syntax %test-error
(syntax-rules () (syntax-rules ()
@ -835,11 +887,11 @@
(%test-report-result))))))) (%test-report-result)))))))
(cond-expand (cond-expand
((or kawa mzscheme) ((or kawa mzscheme guile-2)
(define-syntax test-error (define-syntax test-error
(lambda (x) (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) (((mac tname etype expr) line)
(syntax (syntax
(let* ((r (test-runner-get)) (let* ((r (test-runner-get))
@ -860,11 +912,17 @@
(define-syntax test-error (define-syntax test-error
(syntax-rules () (syntax-rules ()
((test-error name etype expr) ((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-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-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) (define (test-apply first . rest)
(if (test-runner? first) (if (test-runner? first)
@ -873,7 +931,7 @@
(if r (if r
(let ((run-list (%test-runner-run-list r))) (let ((run-list (%test-runner-run-list r)))
(cond ((null? rest) (cond ((null? rest)
(%test-runner-run-list! r (reverse! run-list)) (%test-runner-run-list! r (reverse run-list))
(first)) ;; actually apply procedure thunk (first)) ;; actually apply procedure thunk
(else (else
(%test-runner-run-list! (%test-runner-run-list!
@ -973,7 +1031,9 @@
(let* ((port (open-input-string string)) (let* ((port (open-input-string string))
(form (read port))) (form (read port)))
(if (eof-object? (read-char port)) (if (eof-object? (read-char port))
(eval form) (cond-expand
(guile (eval form (current-module)))
(else (eval form)))
(cond-expand (cond-expand
(srfi-23 (error "(not at eof)")) (srfi-23 (error "(not at eof)"))
(else "error"))))) (else "error")))))