mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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
parent
c4dc4466d6
commit
8fade76f5d
2 changed files with 132 additions and 70 deletions
|
|
@ -4,7 +4,7 @@ (define-module (srfi srfi-64)
|
|||
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 @@ (define-module (srfi srfi-64)
|
|||
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")
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-syntax %test-export
|
|||
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 @@ (define (runner? obj)
|
|||
(> (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 (setter runner value)
|
|||
)
|
||||
|
||||
(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 @@ (define (test-runner-get)
|
|||
(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 @@ (define (%test-any-specifier-matches list runner)
|
|||
(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 @@ (define (test-on-group-begin-simple runner suite-name count)
|
|||
(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 @@ (define (test-on-test-begin-simple runner)
|
|||
(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 @@ (define-syntax %test-evaluate-with-catch
|
|||
((%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 @@ (define-for-syntax (%test-syntax-file form)
|
|||
(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 @@ (define-syntax %test-comp2body
|
|||
(%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 @@ (define-syntax %test-comp1body
|
|||
(%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 @@ (define-syntax test-end
|
|||
(%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 @@ (define-syntax test-assert
|
|||
(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 @@ (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))) ()
|
||||
(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-eq
|
|||
(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 @@ (define-syntax %test-error
|
|||
(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 @@ (define-syntax %test-error
|
|||
(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 @@ (define-syntax %test-error
|
|||
(%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
|
|||
(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 @@ (define (test-apply first . rest)
|
|||
(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 @@ (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
|
||||
(guile (eval form (current-module)))
|
||||
(else (eval form)))
|
||||
(cond-expand
|
||||
(srfi-23 (error "(not at eof)"))
|
||||
(else "error")))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue