conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #173 from KeenS/test 

separate (picrin test) and import some test macros from chibi scheme
This commit is contained in:
Yuichi Nishiwaki 2014-07-21 00:01:42 +09:00
parent 72422343c0 28894dd07a
commit f8904d199f
3 changed files with 106 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
piclib/CMakeLists.txt
View File

@ -3,6 +3,7 @@ list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/prelude.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm

103
piclib/picrin/test.scm Normal file
View File

@ -0,0 +1,103 @@
(define-library (picrin test)
(import (scheme base)
(scheme write)
(scheme read)
(scheme process-context))
(define test-counter 0)
(define counter 0)
(define failure-counter 0)
(define fails '())
(define (print-statistics)
(newline)
(display "Test Result: ")
(write (- counter failure-counter))
(display " / ")
(write counter)
(display " (")
(write (* (/ (- counter failure-counter) counter) 100))
(display "%)")
(display " [PASS/TOTAL]")
(display "")
(newline)
(for-each
(lambda (fail)
(display fail))
fails))
(define (test-begin . o)
(set! test-counter (+ test-counter 1)))
(define (test-end . o)
(set! test-counter (- test-counter 1))
(if (= test-counter 0)
(print-statistics)))
(define-syntax test
(syntax-rules ()
((test expected expr)
(let ((res expr))
(display "case ")
(write counter)
(cond
((equal? res expected)
(display " PASS: ")
(write 'expr)
(display " equals ")
(write expected)
(display "")
(newline)
)
((not (equal? res expected))
(set! failure-counter (+ failure-counter 1))
(let ((out (open-output-string)))
(display " FAIL: " out)
(write 'expr out)
(newline out)
(display " expected " out)
(write expected out)
(display " but got " out)
(write res out)
(display "" out)
(newline out)
(let ((str (get-output-string out)))
(set! fails (cons str fails))
(display str)))))
(set! counter (+ counter 1))))))
(define-syntax test-values
(syntax-rules ()
((_ expect expr)
(test-values #f expect expr))
((_ name expect expr)
(test name (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results))))))
(define (test-failure-count)
(length fails))
(define (test-exit)
(exit (zero? (test-failure-count))))
(define-syntax test-syntax-error
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
(define-syntax test-numeric-syntax
(syntax-rules ()
((test-numeric-syntax str expect strs ...)
(let* ((z (read (open-input-string str)))
(out (open-output-string))
(z-str (begin (write z out) (get-output-string out))))
(test expect (values z))
(test #t (and (member z-str '(str strs ...)) #t))))))
;; (define (test-read-error str)
;; (test-assert
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
(export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax)
)

104
t/r7rs-tests.scm
View File

@ -36,77 +36,14 @@
(scheme write)
; (scheme eval)
(scheme process-context)
(scheme case-lambda))
(scheme case-lambda)
(picrin test))
;; R7RS test suite. Covers all procedures and syntax in the small
;; language except `delete-file'. Currently assumes full-unicode
;; support, the full numeric tower and all standard libraries
;; provided.
(define test-counter 0)
(define counter 0)
(define failure-counter 0)
(define fails '())
(define (print-statistics)
(newline)
(display "Test Result: ")
(write (- counter failure-counter))
(display " / ")
(write counter)
(display " (")
(write (* (/ (- counter failure-counter) counter) 100))
(display "%)")
(display " [PASS/TOTAL]")
(display "")
(newline)
(for-each
(lambda (fail)
(display fail))
fails))
(define (test-begin . o)
(set! test-counter (+ test-counter 1)))
(define (test-end . o)
(set! test-counter (- test-counter 1))
(if (= test-counter 0)
(print-statistics)))
(define-syntax test
(syntax-rules ()
((test expected expr)
(let ((res expr))
(display "case ")
(write counter)
(cond
((equal? res expected)
(display " PASS: ")
(write 'expr)
(display " equals ")
(write expected)
(display "")
(newline)
)
((not (equal? res expected))
(set! failure-counter (+ failure-counter 1))
(let ((out (open-output-string)))
(display " FAIL: " out)
(write 'expr out)
(newline out)
(display " expected " out)
(write expected out)
(display " but got " out)
(write res out)
(display "" out)
(newline out)
(let ((str (get-output-string out)))
(set! fails (cons str fails))
(display str)))))
(set! counter (+ counter 1))))))
(newline)
(test-begin "R7RS")
@ -2089,12 +2026,6 @@
(test '(a . c) (read (open-input-string "(a . #;b c)")))
(test '(a . b) (read (open-input-string "(a . b #;c)")))
;; (define (test-read-error str)
;; (test-assert
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
;; (test-read-error "(#;a . b)")
;; (test-read-error "(a . #;b)")
;; (test-read-error "(a #;. b)")
@ -2138,37 +2069,6 @@
(test-begin "Numeric syntax")
;; Numeric syntax adapted from Peter Bex's tests.
;;
;; These are updated to R7RS, using string ports instead of
;; string->number, and "error" tests removed because implementations
;; are free to provide their own numeric extensions. Currently all
;; tests are run by default - need to cond-expand and test for
;; infinities and -0.0.
(define-syntax test-numeric-syntax
(syntax-rules ()
((test-numeric-syntax str expect strs ...)
(let* ((z (read (open-input-string str)))
(out (open-output-string))
(z-str (begin (write z out) (get-output-string out))))
(test expect (values z))
(test #t (and (member z-str '(str strs ...)) #t))))))
;; Each test is of the form:
;;
;; (test-numeric-syntax input-str expected-value expected-write-values ...)
;;
;; where the input should be eqv? to the expected-value, and the
;; written output the same as any of the expected-write-values. The
;; form
;;
;; (test-numeric-syntax input-str expected-value)
;;
;; is a shorthand for
;;
;; (test-numeric-syntax input-str expected-value (input-str))
;; Simple
(test-numeric-syntax "1" 1)
;; (test-numeric-syntax "+1" 1 "1")