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

fix check-expect-maker contract, reorganize code

Browse Source 
svn: r13157
This commit is contained in:
Eli Barzilay 2009-01-15 23:41:39 +00:00
parent 76657082d9
commit 822a536b7f
1 changed files with 38 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/test-engine/scheme-tests.ss
View File

@ -49,40 +49,45 @@
;; (make-expected-error src string scheme-val) ;; (make-expected-error src string scheme-val)
(define-struct (expected-error check-fail) (message value)) (define-struct (expected-error check-fail) (message value))
;; check-expect-maker : syntax? syntax? (listof syntax?) -> syntax? ;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
;; the common part of all three test forms. ;; the common part of all three test forms.
(define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes hint-tag) (define-for-syntax (check-expect-maker stx checker-proc-stx embedded-stxes
(with-syntax ([bogus-name (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t)] hint-tag)
[src-info (with-stepper-syntax-properties (['stepper-skip-completely #t]) (define bogus-name
#`(list #,@(list #`(quote #,(syntax-source stx)) (stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
(syntax-line stx) (define src-info
(syntax-column stx) (with-stepper-syntax-properties (['stepper-skip-completely #t])
(syntax-position stx) #`(list #,@(list #`(quote #,(syntax-source stx))
(syntax-span stx))))]) (syntax-line stx)
(quasisyntax/loc stx (syntax-column stx)
(define bogus-name (syntax-position stx)
#,(stepper-syntax-property (syntax-span stx)))))
#`(let ([test-info (namespace-variable-value (quasisyntax/loc stx
'test~object #f builder (current-namespace))]) (define #,bogus-name
(when test-info #,(stepper-syntax-property
(insert-test test-info #`(let ([test-info (namespace-variable-value
(lambda () 'test~object #f builder (current-namespace))])
#,(with-stepper-syntax-properties (['stepper-hint hint-tag] (when test-info
['stepper-hide-reduction #t] (insert-test test-info
['stepper-use-val-as-final #t]) (lambda ()
(quasisyntax/loc stx #,(with-stepper-syntax-properties
(#,checker-proc-stx (['stepper-hint hint-tag]
#,@embedded-stxes ['stepper-hide-reduction #t]
src-info ['stepper-use-val-as-final #t])
#,(with-stepper-syntax-properties (['stepper-no-lifting-info #t] (quasisyntax/loc stx
['stepper-hide-reduction #t]) (#,checker-proc-stx
#'test-info)))))))) #,@embedded-stxes
'stepper-skipto #,src-info
(append skipto/third ;; let #,(with-stepper-syntax-properties
skipto/third skipto/second ;; unless (it expands into a begin) (['stepper-no-lifting-info #t]
skipto/cdr skipto/third ;; application of insert-test ['stepper-hide-reduction #t])
'(syntax-e cdr cdr syntax-e car) ;; lambda #'test-info))))))))
)))))) 'stepper-skipto
(append skipto/third ;; let
skipto/third skipto/second ;; unless (it expands into a begin)
skipto/cdr skipto/third ;; application of insert-test
'(syntax-e cdr cdr syntax-e car) ;; lambda
)))))
(define-for-syntax (check-context?) (define-for-syntax (check-context?)
(let ([c (syntax-local-context)]) (let ([c (syntax-local-context)])