Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 22:29:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding test-values

Browse source
This commit is contained in:
Alex Shinn 2010-08-01 17:55:30 +09:00
parent da5d9c677b
commit 2fe2e9f002
2 changed files with 20 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/chibi/test.module
View file

@ -1,7 +1,7 @@
(define-module (chibi test)
(export
test test-error test-assert
test test-error test-assert test-values
test-group current-test-group
test-begin test-end test-syntax-error test-info
test-vars test-run ;;test-exit

25
lib/chibi/test.scm
View file

@ -68,8 +68,7 @@
(test-info name expect expr ()))
((test a ...)
(test-syntax-error 'test "2 or 3 arguments required"
(test a ...)))
))
(test a ...)))))
(define-syntax test-assert
(syntax-rules ()
@ -79,8 +78,15 @@
(test-info name #f expr ((assertion . #t))))
((test a ...)
(test-syntax-error 'test-assert "1 or 2 arguments required"
(test a ...)))
))
(test a ...)))))
(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-syntax test-error
(syntax-rules ()
@ -90,8 +96,7 @@
(test-info name #f expr ((expect-error . #t))))
((test a ...)
(test-syntax-error 'test-error "1 or 2 arguments required"
(test a ...)))
))
(test a ...)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; group interface
@ -219,6 +224,14 @@
(truncate-source (car (reverse x)) (- width 3) #t))))
((and (pair? x) (eq? 'call-with-current-continuation (car x)))
(truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
((and (pair? x) (eq? 'call-with-values (car x)))
(string-append
"..."
(truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x)))
(car (reverse (cadr x)))
(cadr x))
(- width 3)
#t)))
(else
(string-append
(substring str 0 (min (max 0 (- width 3)) (string-length str)))