guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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.
version-0.8.3
Mark H Weaver 8 years ago
parent
c4dc4466d6
commit
8fade76f5d
2 changed files with 132 additions and 70 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 4
      srfi/srfi-64.scm
  2. 198
      srfi/srfi-64.upstream.scm

4
srfi/srfi-64.scm
View File

@ -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")

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
;; 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")))))

Write Preview
Loading…
Cancel
Save