ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Update SRFI-64 to the latest upstream version.

Browse source 
* 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 @@ (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")

144
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
;; 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,6 +166,7 @@ (define (setter runner 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)
@ -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,8 +832,19 @@ (define-syntax %test-error
(kawa
(define-syntax %test-error
(syntax-rules ()
((%test-error r etype expr)
((%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)
@ -807,7 +859,7 @@ (define-syntax %test-error
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
(instance? ex et))
(else #t)))))
(%test-report-result))))))))
(%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")))))