suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

applied Carl's patches

Browse Source 
svn: r5539
This commit is contained in:
Matthias Felleisen 2007-02-02 02:08:45 +00:00
parent 3e62056186
commit 53febf1984
1 changed files with 16 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/htdp/testing.scm
View File

@ -47,17 +47,18 @@
(define-syntax (check-expect stx) (define-syntax (check-expect stx)
(syntax-case stx () (syntax-case stx ()
((_ test actual) ((_ test actual)
#`(define #,(gensym 'test) (quasisyntax/loc stx
(define #,(gensym 'test)
(check-values-expected (check-values-expected
(lambda () test) actual (make-src #,@(list (syntax-source stx) (lambda () test) actual (make-src #,@(list (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx)))))) (syntax-span stx)))))))
((_ test) ((_ test)
(raise-syntax-error 'check-expect CHECK-EXPECT-STR)) (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx))
((_ test actual extra ...) ((_ test actual extra ...)
(raise-syntax-error 'check-expect CHECK-EXPECT-STR)))) (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx))))
;check-values-expected: (-> scheme-val) scheme-val src -> void ;check-values-expected: (-> scheme-val) scheme-val src -> void
(define (check-values-expected test actual src) (define (check-values-expected test actual src)
@ -71,19 +72,20 @@
(define-syntax (check-within stx) (define-syntax (check-within stx)
(syntax-case stx () (syntax-case stx ()
((_ test actual within) ((_ test actual within)
#`(define #,(gensym 'test-within) (quasisyntax/loc stx
(define #,(gensym 'test-within)
(check-values-within (lambda () test) actual within (check-values-within (lambda () test) actual within
(make-src #,@(list (syntax-source stx) (make-src #,@(list (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx)))))) (syntax-span stx)))))))
((_ test actual) ((_ test actual)
(raise-syntax-error 'check-within CHECK-WITHIN-STR)) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
((_ test) ((_ test)
(raise-syntax-error 'check-within CHECK-WITHIN-STR)) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx))
((_ test actual within extra ...) ((_ test actual within extra ...)
(raise-syntax-error 'check-within CHECK-WITHIN-STR)))) (raise-syntax-error 'check-within CHECK-WITHIN-STR stx))))
(define (check-values-within test actual within src) (define (check-values-within test actual within src)
(error-check number? within CHECK-WITHIN-INEXACT-FMT) (error-check number? within CHECK-WITHIN-INEXACT-FMT)
@ -93,14 +95,15 @@
(define-syntax (check-error stx) (define-syntax (check-error stx)
(syntax-case stx () (syntax-case stx ()
((_ test error) ((_ test error)
#`(define #,(gensym 'test-error) (quasisyntax/loc stx
(define #,(gensym 'test-error)
(check-values-error (lambda () test) error (make-src #,@(list (syntax-source stx) (check-values-error (lambda () test) error (make-src #,@(list (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx)))))) (syntax-span stx)))))))
((_ test) ((_ test)
(raise-syntax-error 'check-error CHECK-ERROR-STR)))) (raise-syntax-error 'check-error CHECK-ERROR-STR stx))))
(define (check-values-error test error src) (define (check-values-error test error src)
(error-check string? error CHECK-ERROR-STR-FMT) (error-check string? error CHECK-ERROR-STR-FMT)
@ -272,4 +275,4 @@
" column " (number->string (src-col src)))) " column " (number->string (src-col src))))
) )